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 +++++++++++++++++++++++++++++---- 1 file changed, 326 insertions(+), 40 deletions(-) (limited to 'stdlib/source/lux/data/format/json.lux') 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~' [])))))
-- 
cgit v1.2.3