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

(.module: {#.doc "Functionality for reading and writing values in the JSON format.

                  For more information, please see: http://www.json.org/"}
  [lux (#- Array)]
  (lux (control [monad (#+ do Monad)]
                [equivalence (#+ Equivalence)]
                codec
                ["p" parser "parser/" Monad<Parser>])
       (data [bool]
             [text "text/" Equivalence<Text> Monoid<Text>]
             (text ["l" lexer])
             [number "frac/" Codec<Text,Frac> "nat/" Codec<Text,Nat>]
             [maybe]
             ["e" error]
             [sum]
             [product]
             (collection [list "list/" Fold<List> Monad<List>]
                         [row (#+ Row row) "row/" Monad<Row>]
                         ["dict" dictionary (#+ Dictionary)]))
       [macro (#+ Monad<Meta> with-gensyms)]
       (macro ["s" syntax (#+ syntax:)]
              [code])))

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

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

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

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

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

(type: #export (Reader a)
  {#.doc "JSON reader."}
  (p.Parser (List JSON) a))

(syntax: #export (json token)
  {#.doc (doc "A simple way to produce JSON literals."
              (json true)
              (json 123.456)
              (json "Some text")
              (json #null)
              (json ["this" "is" "an" "array"])
              (json {"this" "is"
                     "an" "object"}))}
  (let [(^open) Monad<Meta>
        wrapper (function (_ x) (` (..json (~ x))))]
    (case token
      (^template [<ast-tag> <ctor> <json-tag>]
        [_ (<ast-tag> value)]
        (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value))))))))
      ([#.Bool code.bool            #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<Meta>
        [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 (dict.from-list text.Hash<Text> (list (~+ pairs')))))))))
      
      _
      (wrap (list token))
      )))

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

    _
    (#e.Error ($_ text/compose "Cannot get the fields of a non-object."))))

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

      #.None
      (#e.Error ($_ text/compose "Missing field \"" key "\" on object.")))

    _
    (#e.Error ($_ 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 (e.Error JSON))
  (case json
    (#Object obj)
    (#e.Success (#Object (dict.put key value obj)))

    _
    (#e.Error ($_ text/compose "Cannot set field \"" key "\" of a non-object."))))

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

       (#e.Success _)
       (#e.Error ($_ text/compose "Wrong value type at key: " key))

       (#e.Error error)
       (#e.Error 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 JSON)
  (def: (= x y)
    (case [x y]
      [#Null #Null]
      true

      (^template [<tag> <struct>]
        [(<tag> x') (<tag> y')]
        (:: <struct> = x' y'))
      ([#Boolean bool.Equivalence<Bool>]
       [#Number  number.Equivalence<Frac>]
       [#String  text.Equivalence<Text>])

      [(#Array xs) (#Array ys)]
      (and (n/= (row.size xs) (row.size ys))
           (list/fold (function (_ idx prev)
                        (and prev
                             (maybe.default false
                                            (do maybe.Monad<Maybe>
                                              [x' (row.nth idx xs)
                                               y' (row.nth idx ys)]
                                              (wrap (= x' y'))))))
                      true
                      (list.indices (row.size xs))))
      
      [(#Object xs) (#Object ys)]
      (and (n/= (dict.size xs) (dict.size ys))
           (list/fold (function (_ [xk xv] prev)
                        (and prev
                             (case (dict.get xk ys)
                               #.None   false
                               (#.Some yv) (= xv yv))))
                      true
                      (dict.entries xs)))
      
      _
      false)))

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

(def: unconsumed-input-error Text "Unconsumed JSON.")

(def: #export (run json parser)
  (All [a] (-> JSON (Reader a) (e.Error a)))
  (case (p.run (list json) parser)
    (#e.Success [remainder output])
    (case remainder
      #.Nil
      (#e.Success output)

      _
      (#e.Error unconsumed-input-error))
    
    (#e.Error error)
    (#e.Error error)))

(def: #export (fail error)
  (All [a] (-> Text (Reader a)))
  (function (_ inputs)
    (#e.Error error)))

(def: #export any
  {#.doc "Just returns the JSON input without applying any logic."}
  (Reader JSON)
  (<| (function (_ inputs))
      (case inputs
        #.Nil
        (#e.Error "Empty JSON stream.")
        
        (#.Cons head tail)
        (#e.Success [tail head]))))

(do-template [<name> <type> <tag> <desc>]
  [(def: #export <name>
     {#.doc (code.text ($_ text/compose "Reads a JSON value as " <desc> "."))}
     (Reader <type>)
     (do p.Monad<Parser>
       [head any]
       (case head
         (<tag> value)
         (wrap value)

         _
         (fail ($_ text/compose "JSON value is not " <desc> ".")))))]

  [null    Any #Null    "null"]
  [boolean Bool #Boolean "boolean"]
  [number  Frac #Number  "number"]
  [string  Text #String  "string"]
  )

(do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>]
  [(def: #export (<test> test)
     {#.doc (code.text ($_ text/compose "Asks whether a JSON value is a " <desc> "."))}
     (-> <type> (Reader Bool))
     (do p.Monad<Parser>
       [head any]
       (case head
         (<tag> value)
         (wrap (:: <eq> = test (<pre> value)))

         _
         (fail ($_ text/compose "JSON value is not " <desc> ".")))))

   (def: #export (<check> test)
     {#.doc (code.text ($_ text/compose "Ensures a JSON value is a " <desc> "."))}
     (-> <type> (Reader Any))
     (do p.Monad<Parser>
       [head any]
       (case head
         (<tag> value)
         (let [value (<pre> value)]
           (if (:: <eq> = test value)
             (wrap [])
             (fail ($_ text/compose "Value mismatch: " (<encoder> test) "=/=" (<encoder> value)))))

         _
         (fail ($_ text/compose "JSON value is not a " <desc> ".")))))]

  [boolean? boolean! Bool bool.Equivalence<Bool>   (:: bool.Codec<Text,Bool> encode)   #Boolean "boolean" id]
  [number?  number!  Frac number.Equivalence<Frac> (:: number.Codec<Text,Frac> encode) #Number  "number"  id]
  [string?  string!  Text text.Equivalence<Text>   text.encode                         #String  "string"  id]
  )

(def: #export (nullable parser)
  (All [a] (-> (Reader a) (Reader (Maybe a))))
  (p.alt null
         parser))

(def: #export (array parser)
  {#.doc "Parses a JSON array, assuming that every element can be parsed the same way."}
  (All [a] (-> (Reader a) (Reader a)))
  (do p.Monad<Parser>
    [head any]
    (case head
      (#Array values)
      (case (p.run (row.to-list values) parser)
        (#e.Error error)
        (fail error)

        (#e.Success [remainder output])
        (case remainder
          #.Nil
          (wrap output)

          _
          (fail unconsumed-input-error)))

      _
      (fail "JSON value is not an array."))))

(def: #export (object parser)
  {#.doc "Parses a JSON object, assuming that every element can be parsed the same way."}
  (All [a] (-> (Reader a) (Reader (Dictionary Text a))))
  (do p.Monad<Parser>
    [head any]
    (case head
      (#Object object)
      (case (do e.Monad<Error>
              []
              (|> (dict.entries object)
                  (monad.map @ (function (_ [key val])
                                 (do @
                                   [val (run val parser)]
                                   (wrap [key val]))))
                  (:: @ map (dict.from-list text.Hash<Text>))))
        (#e.Success table)
        (wrap table)

        (#e.Error error)
        (fail error))

      _
      (fail "JSON value is not an array."))))

(def: #export (field field-name parser)
  {#.doc "Parses a field inside a JSON object."}
  (All [a] (-> Text (Reader a) (Reader a)))
  (do p.Monad<Parser>
    [head any]
    (case head
      (#Object object)
      (case (dict.get field-name object)
        (#.Some value)
        (case (run value parser)
          (#e.Success output)
          (function (_ tail)
            (#e.Success [(#.Cons (#Object (dict.remove field-name object))
                                 tail)
                         output]))

          (#e.Error error)
          (fail error))

        _
        (fail ($_ text/compose "JSON object does not have field \"" field-name "\".")))

      _
      (fail "JSON value is not an object."))))

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

(def: (show-null _) (-> Null Text) "null")
(do-template [<name> <type> <codec>]
  [(def: <name> (-> <type> Text) <codec>)]

  [show-boolean Boolean (:: bool.Codec<Text,Bool> encode)]
  [show-number  Number (:: number.Codec<Text,Frac> encode)]
  [show-string  String text.encode])

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

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

(def: (show-json json)
  (-> JSON Text)
  (case json
    (^template [<tag> <show>]
      (<tag> value)
      (<show> value))
    ([#Null    show-null]
     [#Boolean show-boolean]
     [#Number  show-number]
     [#String  show-string]
     [#Array   (show-array show-json)]
     [#Object  (show-object show-json)])
    ))

(def: space~
  (l.Lexer Text)
  (l.some l.space))

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

(def: null~
  (l.Lexer Null)
  (do p.Monad<Parser>
    [_ (l.this "null")]
    (wrap [])))

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

  [t~ "true"  true]
  [f~ "false" false]
  )

(def: boolean~
  (l.Lexer Boolean)
  (p.either t~ f~))

(def: number~
  (l.Lexer Number)
  (do p.Monad<Parser>
    [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 (frac/decode ($_ text/compose (if signed? "-" "") digits "." decimals exp))
      (#e.Error message)
      (p.fail message)
      
      (#e.Success value)
      (wrap value))))

(def: escaped~
  (l.Lexer Text)
  ($_ p.either
      (p.after (l.this "\\t") (parser/wrap "\t"))
      (p.after (l.this "\\b") (parser/wrap "\b"))
      (p.after (l.this "\\n") (parser/wrap "\n"))
      (p.after (l.this "\\r") (parser/wrap "\r"))
      (p.after (l.this "\\f") (parser/wrap "\f"))
      (p.after (l.this "\\\"") (parser/wrap "\""))
      (p.after (l.this "\\\\") (parser/wrap "\\"))))

(def: string~
  (l.Lexer String)
  (<| (l.enclosed ["\"" "\""])
      (loop [_ []])
      (do p.Monad<Parser>
        [chars (l.some (l.none-of "\\\""))
         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 (l.Lexer JSON)) (l.Lexer [String JSON]))
  (do p.Monad<Parser>
    [key string~
     _ space~
     _ (l.this ":")
     _ space~
     value (json~ [])]
    (wrap [key value])))

(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
  [(def: (<name> json~)
     (-> (-> Any (l.Lexer JSON)) (l.Lexer <type>))
     (do p.Monad<Parser>
       [_ (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~) (dict.from-list text.Hash<Text>)]
  )

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

(structure: #export _ (Codec Text JSON)
  (def: encode show-json)
  (def: decode (function (_ input) (l.run input (json~' [])))))