path: root/stdlib/source/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/")}
  [lux #*
   [abstract
    ["." monad (#+ do)]
    [equivalence (#+ Equivalence)]
    codec]
   [control
    pipe
    ["." try (#+ Try)]
    ["p" parser ("#@." monad)
     ["l" text (#+ Parser)]
     ["s" code]]]
   [data
    ["." bit]
    ["." maybe]
    ["." product]
    [number
     ["f" frac ("#@." decimal)]]
    ["." text ("#@." equivalence monoid)]
    [collection
     ["." list ("#@." fold functor)]
     ["." row (#+ Row row) ("#@." monad)]
     ["." dictionary (#+ Dictionary)]]]
   ["." macro (#+ monad with-gensyms)
    [syntax (#+ syntax:)]
    ["." code]]])

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

(syntax: #export (json token)
  {#.doc (doc "A simple way to produce JSON literals."
              (json #1)
              (json +123.456)
              (json "Some text")
              (json #null)
              (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))]))

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

(def: #export (get-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 "' of 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 "' of 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"]
  )

(structure: #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>
        +0.0 "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: format-string (-> String Text) text.encode)

(def: (format-array format elems)
  (-> (-> JSON Text) (-> Array Text))
  ($_ text@compose "["
      (|> elems (row@map format) row.to-list (text.join-with ","))
      "]"))

(def: (format-object format object)
  (-> (-> JSON Text) (-> Object Text))
  ($_ text@compose "{"
      (|> object
          dictionary.entries
          (list@map (function (_ [key value]) ($_ text@compose (format-string key) ":" (format value))))
          (text.join-with ","))
      "}"))

(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: space~
  (Parser Text)
  (l.some l.space))

(def: data-sep
  (Parser [Text Any Text])
  ($_ p.and space~ (l.this ",") space~))

(def: null~
  (Parser Null)
  (do p.monad
    [_ (l.this "null")]
    (wrap [])))

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

  [true~  "true"  #1]
  [false~ "false" #0]
  )

(def: boolean~
  (Parser Boolean)
  (p.either true~ false~))

(def: number~
  (Parser Number)
  (do p.monad
    [signed? (l.this? "-")
     digits (l.many l.decimal)
     decimals (p.default "0"
                         (do @
                           [_ (l.this ".")]
                           (l.many l.decimal)))
     exp (p.default ""
                    (do @
                      [mark (l.one-of "eE")
                       signed?' (l.this? "-")
                       offset (l.many l.decimal)]
                      (wrap ($_ text@compose mark (if signed?' "-" "") offset))))]
    (case (f@decode ($_ text@compose (if signed? "-" "") digits "." decimals exp))
      (#try.Failure message)
      (p.fail message)
      
      (#try.Success value)
      (wrap value))))

(def: escaped~
  (Parser Text)
  ($_ p.either
      (p.after (l.this "\t")
               (p@wrap text.tab))
      (p.after (l.this "\b")
               (p@wrap text.back-space))
      (p.after (l.this "\n")
               (p@wrap text.new-line))
      (p.after (l.this "\r")
               (p@wrap text.carriage-return))
      (p.after (l.this "\f")
               (p@wrap text.form-feed))
      (p.after (l.this (text@compose "\" text.double-quote))
               (p@wrap text.double-quote))
      (p.after (l.this "\\")
               (p@wrap "\"))))

(def: string~
  (Parser String)
  (<| (l.enclosed [text.double-quote text.double-quote])
      (loop [_ []])
      (do p.monad
        [chars (l.some (l.none-of (text@compose "\" text.double-quote)))
         stop l.peek])
      (if (text@= "\" stop)
        (do @
          [escaped escaped~
           next-chars (recur [])]
          (wrap ($_ text@compose chars escaped next-chars)))
        (wrap chars))))

(def: (kv~ json~)
  (-> (-> Any (Parser JSON)) (Parser [String JSON]))
  (do p.monad
    [key string~
     _ space~
     _ (l.this ":")
     _ space~
     value (json~ [])]
    (wrap [key value])))

(template [<name> <type> <open> <close> <elem-parser> <prep>]
  [(def: (<name> json~)
     (-> (-> Any (Parser JSON)) (Parser <type>))
     (do p.monad
       [_ (l.this <open>)
        _ space~
        elems (p.sep-by data-sep <elem-parser>)
        _ space~
        _ (l.this <close>)]
       (wrap (<prep> elems))))]

  [array~  Array  "[" "]" (json~ [])  row.from-list]
  [object~ Object "{" "}" (kv~ json~) (dictionary.from-list text.hash)]
  )

(def: (json~' _)
  (-> Any (Parser JSON))
  ($_ p.or null~ boolean~ number~ string~ (array~ json~') (object~ json~')))

(structure: #export codec (Codec Text JSON)
  (def: encode ..format)
  (def: decode (l.run (json~' []))))