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

(.module:
  {#.doc (.example "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
     ["." maybe]
     ["." try (#+ Try)]
     ["<>" parser ("#\." monad)
      ["<.>" text (#+ Parser)]
      ["<.>" code]]]
    [data
     ["." bit]
     ["." product]
     ["." text ("#\." equivalence monoid)]
     [collection
      ["." list ("#\." fold functor)]
      ["." row (#+ Row row) ("#\." monad)]
      ["." dictionary (#+ Dictionary)]]]
    [macro
     [syntax (#+ syntax:)]
     ["." code]]
    [math
     [number
      ["n" nat]
      ["f" frac ("#\." decimal)]]]]])

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

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

(type: .public #rec JSON
  (#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))

(syntax: .public (json [token <code>.any])
  {#.doc (example "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)]
         (in (list (` (: JSON (<json_tag> (~ (<ctor> value)))))))])
      ([#.Bit  code.bit  #..Boolean]
       [#.Frac code.frac #..Number]
       [#.Text code.text #..String])

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

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

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

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

(def: .public (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: .public (field key json)
  {#.doc "A JSON object field getter."}
  (-> String JSON (Try JSON))
  (case json
    (#Object obj)
    (case (dictionary.value 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: .public (has key value json)
  {#.doc "A JSON object field setter."}
  (-> String JSON JSON (Try JSON))
  (case json
    (#Object obj)
    (#try.Success (#Object (dictionary.has key value obj)))

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

(template [<name> <tag> <type> <desc>]
  [(def: .public (<name> key json)
     {#.doc (code.text ($_ text\compose "A JSON object field getter for " <desc> "."))}
     (-> Text JSON (Try <type>))
     (case (field 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)))]

  [boolean_field #Boolean Boolean "booleans"]
  [number_field  #Number  Number  "numbers"]
  [string_field  #String  String  "strings"]
  [array_field   #Array   Array   "arrays"]
  [object_field  #Object  Object  "objects"]
  )

(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\fold (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\fold (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 encode value)]
                (if (f.< +0.0 value)
                  raw
                  (|> raw (text.split_at 1) maybe.assume product.right))))))

(def: escape "\")
(def: escaped_dq (text\compose ..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\map format)
       row.list
       (text.join_with ..value_separator)
       (text.enclosed [..array_start ..array_end])))

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

(def: (object_format format)
  (-> (-> JSON Text) (-> Object Text))
  (|>> dictionary.entries
       (list\map (..kv_format format))
       (text.join_with ..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\compose mark (if signed?' "-" "") offset))))]
    (case (f\decode ($_ text\compose (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\compose "\" 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\compose "\" text.double_quote)))
         stop <text>.next])
      (if (text\= "\" stop)
        (do !
          [escaped escaped_parser
           next_chars (recur [])]
          (in ($_ text\compose 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: encode ..format)
  (def: decode (<text>.result json_parser)))