From 036f3b68983381c6fd2c380f01011ddaf0d8021f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 4 Sep 2017 21:16:42 -0400 Subject: - Simplified code for JSON format. - Moved JSON polytypism to the lux/macro/poly/* branch. --- stdlib/source/lux/data/format/json.lux | 366 ++++++++++++++++++--- stdlib/source/lux/data/format/json/codec.lux | 439 -------------------------- stdlib/source/lux/data/format/json/reader.lux | 177 ----------- stdlib/source/lux/data/text/format.lux | 5 +- stdlib/source/lux/macro/poly/json.lux | 296 +++++++++++++++++ 5 files changed, 624 insertions(+), 659 deletions(-) delete mode 100644 stdlib/source/lux/data/format/json/codec.lux delete mode 100644 stdlib/source/lux/data/format/json/reader.lux create mode 100644 stdlib/source/lux/macro/poly/json.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 847b5fa0f..097525b1d 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -1,10 +1,10 @@ -(;module: {#;doc "Functionality for generating and processing values in the JSON format. +(;module: {#;doc "Functionality for reading and writing values in the JSON format. For more information, please see: http://www.json.org/"} lux (lux (control functor applicative - ["M" monad #+ do Monad] + [monad #+ do Monad] [eq #+ Eq] codec ["p" parser "p/" Monad]) @@ -26,7 +26,6 @@ [type] )) -## [Types] (do-template [ ] [(type: #export )] @@ -55,7 +54,6 @@ {#;doc "JSON reader."} (p;Parser (List JSON) a)) -## [Syntax] (syntax: #export (json token) {#;doc (doc "A simple way to produce JSON literals." (json true) @@ -83,27 +81,22 @@ [_ (#;Record pairs)] (do Monad - [pairs' (M;map @ - (function [[slot value]] - (case slot - [_ (#;Text key-name)] - (wrap (` [(~ (code;text key-name)) (~ (wrapper value))])) - - _ - (macro;fail "Wrong syntax for JSON object."))) - pairs)] + [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 (d;from-list text;Hash (list (~@ pairs'))))))))) _ (wrap (list token)) ))) -(def: #export null - {#;doc "The null JSON value."} - JSON - #Null) - -(def: #export (fields json) +(def: #export (get-fields json) {#;doc "Get all the fields in a JSON object."} (-> JSON (R;Result (List String))) (case json @@ -159,27 +152,6 @@ [get-object #Object Object "objects"] ) -(do-template [ ] - [(def: #export ( value) - {#;doc (#;TextA ($_ text/append "A JSON generator for " "."))} - (-> JSON) - ( value))] - - [boolean Boolean #Boolean "booleans"] - [number Number #Number "numbers"] - [string String #String "strings"] - [array Array #Array "arrays"] - [object Object #Object "objects"] - ) - -(def: #export (nullable writer) - {#;doc "Builds a JSON generator for potentially inexistent values."} - (All [a] (-> (-> a JSON) (-> (Maybe a) JSON))) - (function [elem] - (case elem - #;None #Null - (#;Some value) (writer value)))) - (struct: #export _ (Eq JSON) (def: (= x y) (case [x y] @@ -217,3 +189,317 @@ _ false))) + +############################################################ +############################################################ +############################################################ + +(def: unconsumed-input-error Text "Unconsumed JSON.") + +(def: #export (run json parser) + (All [a] (-> JSON (Reader a) (R;Result a))) + (case (p;run (list json) parser) + (#R;Success [remainder output]) + (case remainder + #;Nil + (#R;Success output) + + _ + (#R;Error unconsumed-input-error)) + + (#R;Error error) + (#R;Error error))) + +(def: #export (fail error) + (All [a] (-> Text (Reader a))) + (function [inputs] + (#R;Error error))) + +(def: #export any + {#;doc "Just returns the JSON input without applying any logic."} + (Reader JSON) + (<| (function [inputs]) + (case inputs + #;Nil + (#R;Error "Empty JSON stream.") + + (#;Cons head tail) + (#R;Success [tail head])))) + +(do-template [ ] + [(def: #export + {#;doc (#;TextA ($_ text/append "Reads a JSON value as " "."))} + (Reader ) + (do p;Monad + [head any] + (case head + ( value) + (wrap value) + + _ + (fail ($_ text/append "JSON value is not " ".")))))] + + [null Unit #Null "null"] + [boolean Bool #Boolean "boolean"] + [number Frac #Number "number"] + [string Text #String "string"] + ) + +(do-template [
]
+  [(def: #export ( test)
+     {#;doc (#;TextA ($_ text/append "Asks whether a JSON value is a "  "."))}
+     (->  (Reader Bool))
+     (do p;Monad
+       [head any]
+       (case head
+         ( value)
+         (wrap (::  = test (
 value)))
+
+         _
+         (fail ($_ text/append "JSON value is not "  ".")))))
+
+   (def: #export ( test)
+     {#;doc (#;TextA ($_ text/append "Ensures a JSON value is a "  "."))}
+     (->  (Reader Unit))
+     (do p;Monad
+       [head any]
+       (case head
+         ( value)
+         (let [value (
 value)]
+           (if (::  = test value)
+             (wrap [])
+             (fail ($_ text/append "Value mismatch: " ( test) "=/=" ( value)))))
+
+         _
+         (fail ($_ text/append "JSON value is not a "  ".")))))]
+
+  [boolean? boolean! Bool bool;Eq   (:: bool;Codec encode)   #Boolean "boolean" id]
+  [number?  number!  Frac number;Eq (:: number;Codec encode) #Number  "number"  id]
+  [string?  string!  Text text;Eq   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
+    [head any]
+    (case head
+      (#Array values)
+      (case (p;run (vector;to-list values) parser)
+        (#R;Error error)
+        (fail error)
+
+        (#R;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 (d;Dict Text a))))
+  (do p;Monad
+    [head any]
+    (case head
+      (#Object object)
+      (case (do R;Monad
+              []
+              (|> (d;entries object)
+                  (monad;map @ (function [[key val]]
+                                 (do @
+                                   [val (run val parser)]
+                                   (wrap [key val]))))
+                  (:: @ map (d;from-list text;Hash))))
+        (#R;Success table)
+        (wrap table)
+
+        (#R;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
+    [head any]
+    (case head
+      (#Object object)
+      (case (d;get field-name object)
+        (#;Some value)
+        (case (run value parser)
+          (#R;Success output)
+          (function [tail]
+            (#R;Success [(#;Cons (#Object (d;remove field-name object))
+                                 tail)
+                         output]))
+
+          (#R;Error error)
+          (fail error))
+
+        _
+        (fail ($_ text/append "JSON object does not have field \"" field-name "\".")))
+
+      _
+      (fail "JSON value is not an object."))))
+
+############################################################
+############################################################
+############################################################
+
+(def: #hidden (show-null _) (-> Null Text) "null")
+(do-template [  ]
+  [(def:  (->  Text) )]
+
+  [show-boolean Boolean (:: bool;Codec encode)]
+  [show-number  Number (:: number;Codec encode)]
+  [show-string  String text;encode])
+
+(def: (show-array show-json elems)
+  (-> (-> JSON Text) (-> Array Text))
+  ($_ text/append "["
+      (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
+      "]"))
+
+(def: (show-object show-json object)
+  (-> (-> JSON Text) (-> Object Text))
+  ($_ text/append "{"
+      (|> object
+          d;entries
+          (L/map (function [[key value]] ($_ text/append (show-string key) ":" (show-json value))))
+          (text;join-with ","))
+      "}"))
+
+(def: (show-json json)
+  (-> JSON Text)
+  (case json
+    (^template [ ]
+      ( value)
+      ( 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 Unit Text])
+  ($_ p;seq space~ (l;this ",") space~))
+
+(def: null~
+  (l;Lexer Null)
+  (do p;Monad
+    [_ (l;this "null")]
+    (wrap [])))
+
+(do-template [  ]
+  [(def: 
+     (l;Lexer Boolean)
+     (do p;Monad
+       [_ (l;this )]
+       (wrap )))]
+
+  [t~ "true"  true]
+  [f~ "false" false]
+  )
+
+(def: boolean~
+  (l;Lexer Boolean)
+  (p;either t~ f~))
+
+(def: number~
+  (l;Lexer 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/append mark (if signed?' "-" "") offset))))]
+    (case (frac/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
+      (#R;Error message)
+      (p;fail message)
+      
+      (#R;Success value)
+      (wrap value))))
+
+(def: escaped~
+  (l;Lexer Text)
+  ($_ p;either
+      (p;after (l;this "\\t") (p/wrap "\t"))
+      (p;after (l;this "\\b") (p/wrap "\b"))
+      (p;after (l;this "\\n") (p/wrap "\n"))
+      (p;after (l;this "\\r") (p/wrap "\r"))
+      (p;after (l;this "\\f") (p/wrap "\f"))
+      (p;after (l;this "\\\"") (p/wrap "\""))
+      (p;after (l;this "\\\\") (p/wrap "\\"))))
+
+(def: string~
+  (l;Lexer String)
+  (<| (l;enclosed ["\"" "\""])
+      (loop [_ []])
+      (do p;Monad
+        [chars (l;some (l;none-of "\\\""))
+         stop l;peek])
+      (if (text/= "\\" stop)
+        (do @
+          [escaped escaped~
+           next-chars (recur [])]
+          (wrap ($_ text/append chars escaped next-chars)))
+        (wrap chars))))
+
+(def: (kv~ json~)
+  (-> (-> Unit (l;Lexer JSON)) (l;Lexer [String JSON]))
+  (do p;Monad
+    [key string~
+     _ space~
+     _ (l;this ":")
+     _ space~
+     value (json~ [])]
+    (wrap [key value])))
+
+(do-template [     ]
+  [(def: ( json~)
+     (-> (-> Unit (l;Lexer JSON)) (l;Lexer ))
+     (do p;Monad
+       [_ (l;this )
+        _ space~
+        elems (p;sep-by data-sep )
+        _ space~
+        _ (l;this )]
+       (wrap ( elems))))]
+
+  [array~  Array  "[" "]" (json~ [])  vector;from-list]
+  [object~ Object "{" "}" (kv~ json~) (d;from-list text;Hash)]
+  )
+
+(def: (json~' _)
+  (-> Unit (l;Lexer JSON))
+  ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
+
+(struct: #export _ (Codec Text JSON)
+  (def: encode show-json)
+  (def: decode (function [input] (l;run input (json~' [])))))
diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
deleted file mode 100644
index 6fa1d566c..000000000
--- a/stdlib/source/lux/data/format/json/codec.lux
+++ /dev/null
@@ -1,439 +0,0 @@
-(;module: {#;doc "Codecs for values in the JSON format.
-
-                  For more information, please see: http://www.json.org/"}
-  lux
-  (lux (control functor
-                applicative
-                [monad #+ do Monad]
-                [eq #+ Eq]
-                codec
-                ["p" parser "p/" Monad])
-       (data [bool]
-             [bit]
-             [text "text/" Eq Monoid]
-             (text ["l" lexer])
-             [number "frac/" Codec "nat/" Codec]
-             maybe
-             ["R" result]
-             [sum]
-             [product]
-             (coll [list "L/" Fold Monad]
-                   [vector #+ Vector vector "Vector/" Monad]
-                   ["d" dict]))
-       (time ["i" instant]
-             ["du" duration]
-             ["da" date])
-       [macro #+ Monad with-gensyms]
-       (macro ["s" syntax #+ syntax:]
-              [code]
-              [poly #+ poly:])
-       [type]
-       )
-  [.. #+ JSON]
-  [../reader])
-
-## [Values]
-(def: #hidden (show-null _) (-> ..;Null Text) "null")
-(do-template [  ]
-  [(def:  (->  Text) )]
-
-  [show-boolean ..;Boolean (:: bool;Codec encode)]
-  [show-number  ..;Number (:: number;Codec encode)]
-  [show-string  ..;String text;encode])
-
-(def: (show-array show-json elems)
-  (-> (-> JSON Text) (-> ..;Array Text))
-  ($_ text/append "["
-      (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
-      "]"))
-
-(def: (show-object show-json object)
-  (-> (-> JSON Text) (-> ..;Object Text))
-  ($_ text/append "{"
-      (|> object
-          d;entries
-          (L/map (function [[key value]] ($_ text/append (show-string key) ":" (show-json value))))
-          (text;join-with ","))
-      "}"))
-
-(def: (show-json json)
-  (-> JSON Text)
-  (case json
-    (^template [ ]
-      ( value)
-      ( 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 Unit Text])
-  ($_ p;seq space~ (l;this ",") space~))
-
-(def: null~
-  (l;Lexer ..;Null)
-  (do p;Monad
-    [_ (l;this "null")]
-    (wrap [])))
-
-(do-template [  ]
-  [(def: 
-     (l;Lexer ..;Boolean)
-     (do p;Monad
-       [_ (l;this )]
-       (wrap )))]
-
-  [t~ "true"  true]
-  [f~ "false" false]
-  )
-
-(def: boolean~
-  (l;Lexer ..;Boolean)
-  (p;either t~ f~))
-
-(def: number~
-  (l;Lexer ..;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/append mark (if signed?' "-" "") offset))))]
-    (case (frac/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
-      (#R;Error message)
-      (p;fail message)
-      
-      (#R;Success value)
-      (wrap value))))
-
-(def: escaped~
-  (l;Lexer Text)
-  ($_ p;either
-      (p;after (l;this "\\t") (p/wrap "\t"))
-      (p;after (l;this "\\b") (p/wrap "\b"))
-      (p;after (l;this "\\n") (p/wrap "\n"))
-      (p;after (l;this "\\r") (p/wrap "\r"))
-      (p;after (l;this "\\f") (p/wrap "\f"))
-      (p;after (l;this "\\\"") (p/wrap "\""))
-      (p;after (l;this "\\\\") (p/wrap "\\"))))
-
-(def: string~
-  (l;Lexer ..;String)
-  (<| (l;enclosed ["\"" "\""])
-      (loop [_ []])
-      (do p;Monad
-        [chars (l;some (l;none-of "\\\""))
-         stop l;peek])
-      (if (text/= "\\" stop)
-        (do @
-          [escaped escaped~
-           next-chars (recur [])]
-          (wrap ($_ text/append chars escaped next-chars)))
-        (wrap chars))))
-
-(def: (kv~ json~)
-  (-> (-> Unit (l;Lexer JSON)) (l;Lexer [..;String JSON]))
-  (do p;Monad
-    [key string~
-     _ space~
-     _ (l;this ":")
-     _ space~
-     value (json~ [])]
-    (wrap [key value])))
-
-(do-template [     ]
-  [(def: ( json~)
-     (-> (-> Unit (l;Lexer JSON)) (l;Lexer ))
-     (do p;Monad
-       [_ (l;this )
-        _ space~
-        elems (p;sep-by data-sep )
-        _ space~
-        _ (l;this )]
-       (wrap ( elems))))]
-
-  [array~  ..;Array  "[" "]" (json~ [])  vector;from-list]
-  [object~ ..;Object "{" "}" (kv~ json~) (d;from-list text;Hash)]
-  )
-
-(def: (json~' _)
-  (-> Unit (l;Lexer JSON))
-  ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
-
-(struct: #export _ (Codec Text JSON)
-  (def: encode show-json)
-  (def: decode (function [input] (l;run input (json~' [])))))
-
-## [Polytypism]
-(def: #hidden _map_
-  (All [a b] (-> (-> a b) (List a) (List b)))
-  L/map)
-
-(def: tag
-  (-> Nat Frac)
-  (|>. nat-to-int int-to-frac))
-
-(def: #hidden (rec-encode non-rec)
-  (All [a] (-> (-> (-> a JSON)
-                   (-> a JSON))
-               (-> a JSON)))
-  (function [input]
-    (non-rec (rec-encode non-rec) input)))
-
-(def: low-mask Nat (|> +1 (bit;shift-left +32) n.dec))
-(def: high-mask Nat (|> low-mask (bit;shift-left +32)))
-
-(struct: #hidden _ (Codec JSON Nat)
-  (def: (encode input)
-    (let [high (|> input (bit;and high-mask) (bit;unsigned-shift-right +32))
-          low (bit;and low-mask input)]
-      (..;array (vector (|> high nat-to-int int-to-frac #..;Number)
-                        (|> low nat-to-int int-to-frac #..;Number)))))
-  (def: (decode input)
-    (<| (../reader;run input)
-        (do p;Monad
-          [high ../reader;number
-           low ../reader;number])
-        (wrap (n.+ (|> high frac-to-int int-to-nat (bit;shift-left +32))
-                   (|> low frac-to-int int-to-nat))))))
-
-(struct: #hidden _ (Codec JSON Int)
-  (def: encode (|>. int-to-nat (:: Codec encode)))
-  (def: decode
-    (|>. (:: Codec decode) (:: R;Functor map nat-to-int))))
-
-(poly: #hidden Codec//encode
-  (with-expansions
-    [ (do-template [  ]
-               [(do @
-                  [_ ]
-                  (wrap (` (: (~ (@JSON//encode inputT))
-                              ))))]
-
-               [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
-               [Bool poly;bool ..;boolean]
-               [Nat  poly;nat  (:: ;;Codec (~' encode))]
-               [Int  poly;int  (:: ;;Codec (~' encode))]
-               [Frac poly;frac ..;number]
-               [Text poly;text ..;string])
-