Normalized the hierarchy of the standard library modules.

1 files changed, 422 insertions, 0 deletions

diff --git a/stdlib/source/library/lux/data/format/json.lux b/stdlib/source/library/lux/data/format/json.lux
new file mode 100644
index 000000000..142a15610
--- /dev/null
+++ b/stdlib/source/library/lux/data/format/json.lux
@@ -0,0 +1,422 @@
+(.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)))