From d0ec271e90a2be17d2ad5f5e23b0bb3006602bc8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 21 Jun 2017 19:10:24 -0400 Subject: - CLI, Syntax and Lexer are now based upon a common Parser type. --- stdlib/source/lux/data/format/json.lux | 207 ++++++++++++++++----------------- 1 file changed, 102 insertions(+), 105 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 6cf45dfc9..573849b9e 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -6,22 +6,23 @@ applicative monad eq - codec) + codec + ["p" parser "p/" Monad]) (data [bool] [text "Text/" Eq Monoid] text/format - (text ["l" lexer #+ Lexer Monad "Lexer/" Monad]) + (text ["l" lexer]) [number "Real/" Codec] maybe [char "Char/" Codec] ["R" result] [sum] [product] - (coll [list "" Fold "List/" Monad] + (coll [list "L/" Fold Monad] [vector #+ Vector vector "Vector/" Monad] ["d" dict])) [macro #+ Monad with-gensyms] - (macro [syntax #+ syntax:] + (macro ["s" syntax #+ syntax:] [code] [poly #+ poly:]) [type] @@ -86,7 +87,7 @@ (wrap (list (` (: JSON #Null)))) [_ (#;Tuple members)] - (wrap (list (` (: JSON (#Array (vector (~@ (List/map wrapper members)))))))) + (wrap (list (` (: JSON (#Array (vector (~@ (L/map wrapper members)))))))) [_ (#;Record pairs)] (do Monad @@ -125,7 +126,7 @@ (format "{" (|> object d;entries - (List/map (function [[key value]] (format (:: text;Codec encode key) ":" (show-json value)))) + (L/map (function [[key value]] (format (:: text;Codec encode key) ":" (show-json value)))) (text;join-with ",")) "}")) @@ -227,23 +228,23 @@ ## Lexers (def: space~ - (Lexer Text) - (l;some' l;space)) + (l;Lexer Text) + (l;some l;space)) (def: data-sep - (Lexer [Text Unit Text]) - ($_ l;seq space~ (l;this ",") space~)) + (l;Lexer [Text Unit Text]) + ($_ p;seq space~ (l;this ",") space~)) (def: null~ - (Lexer Null) - (do Monad + (l;Lexer Null) + (do p;Monad [_ (l;this "null")] (wrap []))) (do-template [ ] [(def: - (Lexer Boolean) - (do Monad + (l;Lexer Boolean) + (do p;Monad [_ (l;this )] (wrap )))] @@ -252,52 +253,48 @@ ) (def: boolean~ - (Lexer Boolean) - (l;either t~ f~)) + (l;Lexer Boolean) + (p;either t~ f~)) (def: number~ - (Lexer Number) - (do Monad + (l;Lexer Number) + (do p;Monad [signed? (l;this? "-") - digits (: (Lexer Text) - (l;many' l;digit)) - decimals (: (Lexer Text) - (l;default "0" - (do @ - [_ (l;this ".")] - (l;many' l;digit)))) - exp (: (Lexer Text) - (l;default "" - (do @ - [mark (l;one-of "eE") - signed?' (l;this? "-") - offset (l;many' l;digit)] - (wrap (format mark (if signed?' "-" "") offset)))))] - (case (: (R;Result Real) - (Real/decode (format (if signed? "-" "") digits "." decimals exp))) + digits (l;many l;digit) + decimals (p;default "0" + (do @ + [_ (l;this ".")] + (l;many l;digit))) + exp (p;default "" + (do @ + [mark (l;one-of "eE") + signed?' (l;this? "-") + offset (l;many l;digit)] + (wrap (format mark (if signed?' "-" "") offset))))] + (case (Real/decode (format (if signed? "-" "") digits "." decimals exp)) (#R;Error message) - (l;fail message) + (p;fail message) (#R;Success value) (wrap value)))) (def: escaped~ - (Lexer Text) - ($_ l;either - (l;after (l;this "\\t") (Lexer/wrap "\t")) - (l;after (l;this "\\b") (Lexer/wrap "\b")) - (l;after (l;this "\\n") (Lexer/wrap "\n")) - (l;after (l;this "\\r") (Lexer/wrap "\r")) - (l;after (l;this "\\f") (Lexer/wrap "\f")) - (l;after (l;this "\\\"") (Lexer/wrap "\"")) - (l;after (l;this "\\\\") (Lexer/wrap "\\")))) + (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~ - (Lexer String) + (l;Lexer String) (<| (l;enclosed ["\"" "\""]) (loop [_ []] - (do Monad - [chars (l;some' (l;none-of "\\\"")) + (do p;Monad + [chars (l;some (l;none-of "\\\"")) stop l;peek] (if (Text/= "\\" stop) (do @ @@ -307,8 +304,8 @@ (wrap chars)))))) (def: (kv~ json~) - (-> (-> Unit (Lexer JSON)) (Lexer [String JSON])) - (do Monad + (-> (-> Unit (l;Lexer JSON)) (l;Lexer [String JSON])) + (do p;Monad [key string~ _ space~ _ (l;this ":") @@ -318,11 +315,11 @@ (do-template [ ] [(def: ( json~) - (-> (-> Unit (Lexer JSON)) (Lexer )) - (do Monad + (-> (-> Unit (l;Lexer JSON)) (l;Lexer )) + (do p;Monad [_ (l;this ) _ space~ - elems (l;sep-by data-sep ) + elems (p;sep-by data-sep ) _ space~ _ (l;this )] (wrap ( elems))))] @@ -332,8 +329,8 @@ ) (def: (json~' _) - (-> Unit (Lexer JSON)) - ($_ l;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) + (-> Unit (l;Lexer JSON)) + ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) ## [Structures] (struct: #export _ (Functor Parser) @@ -669,25 +666,25 @@ [(#Array xs) (#Array ys)] (and (n.= (vector;size xs) (vector;size ys)) - (fold (function [idx prev] - (and prev - (default false - (do Monad - [x' (vector;nth idx xs) - y' (vector;nth idx ys)] - (wrap (= x' y')))))) - true - (list;indices (vector;size xs)))) + (L/fold (function [idx prev] + (and prev + (default false + (do Monad + [x' (vector;nth idx xs) + y' (vector;nth idx ys)] + (wrap (= x' y')))))) + true + (list;indices (vector;size xs)))) [(#Object xs) (#Object ys)] (and (n.= (d;size xs) (d;size ys)) - (fold (function [[xk xv] prev] - (and prev - (case (d;get xk ys) - #;None false - (#;Some yv) (= xv yv)))) - true - (d;entries xs))) + (L/fold (function [[xk xv] prev] + (and prev + (case (d;get xk ys) + #;None false + (#;Some yv) (= xv yv)))) + true + (d;entries xs))) _ false))) @@ -702,9 +699,9 @@ (#ObjectShape (List [Text Code]))) (def: _shape^ - (syntax;Syntax Shape) - (syntax;alt (syntax;tuple (syntax;some syntax;any)) - (syntax;record (syntax;some (syntax;seq syntax;text syntax;any))))) + (s;Syntax Shape) + (p;alt (s;tuple (p;some s;any)) + (s;record (p;some (p;seq s;text s;any))))) (syntax: #export (shape [shape _shape^]) {#;doc (doc "Builds a parser that ensures the (inclusive) shape of an array or object." @@ -717,15 +714,15 @@ (let [array-size (list;size parts) parsers (|> parts (list;zip2 (list;indices array-size)) - (List/map (function [[idx parser]] - (` (nth (~ (code;nat idx)) (~ parser))))))] + (L/map (function [[idx parser]] + (` (nth (~ (code;nat idx)) (~ parser))))))] (wrap (list (` ($_ seq (~@ parsers)))))) (#ObjectShape kvs) - (let [fields (List/map product;left kvs) - parsers (List/map (function [[field-name parser]] - (` (field (~ (code;text field-name)) (~ parser)))) - kvs)] + (let [fields (L/map product;left kvs) + parsers (L/map (function [[field-name parser]] + (` (field (~ (code;text field-name)) (~ parser)))) + kvs)] (wrap (list (` ($_ seq (~@ parsers)))))) )) @@ -740,24 +737,24 @@ (let [array-size (list;size parts) parsers (|> parts (list;zip2 (list;indices array-size)) - (List/map (function [[idx parser]] - (` (nth (~ (code;nat idx)) (~ parser))))))] + (L/map (function [[idx parser]] + (` (nth (~ (code;nat idx)) (~ parser))))))] (wrap (list (` (ensure (array-size! (~ (code;nat array-size))) ($_ seq (~@ parsers))))))) (#ObjectShape kvs) - (let [fields (List/map product;left kvs) - parsers (List/map (function [[field-name parser]] - (` (field (~ (code;text field-name)) (~ parser)))) - kvs)] - (wrap (list (` (ensure (object-fields! (list (~@ (List/map code;text fields)))) + (let [fields (L/map product;left kvs) + parsers (L/map (function [[field-name parser]] + (` (field (~ (code;text field-name)) (~ parser)))) + kvs)] + (wrap (list (` (ensure (object-fields! (list (~@ (L/map code;text fields)))) ($_ seq (~@ parsers))))))) )) ## [Polytypism] (def: #hidden _map_ (All [a b] (-> (-> a b) (List a) (List b))) - List/map) + L/map) (poly: #hidden (Codec//encode *env* :x:) (let [->Codec//encode (: (-> Code Code) @@ -823,12 +820,12 @@ _ (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (List/map ->Codec//encode g!vars)) + (-> (~@ (L/map ->Codec//encode g!vars)) (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] (case (~ g!input) - (~@ (List/join pattern-matching)))) + (~@ (L/join pattern-matching)))) ))))) (with-gensyms [g!type-fun g!case g!input] (do @ @@ -849,7 +846,7 @@ _ (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (List/map ->Codec//encode g!vars)) + (-> (~@ (L/map ->Codec//encode g!vars)) (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] @@ -874,14 +871,14 @@ _ (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (List/map ->Codec//encode g!vars)) + (-> (~@ (L/map ->Codec//encode g!vars)) (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))] - #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]] + #let [.tuple. (` [(~@ (L/map product;left pattern-matching))])]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ .tuple.)] - (;;json [(~@ (List/map (function [[g!member g!encoder]] - (` ((~ g!encoder) (~ g!member)))) - pattern-matching))])) + (;;json [(~@ (L/map (function [[g!member g!encoder]] + (` ((~ g!encoder) (~ g!member)))) + pattern-matching))])) ))) )) (do @ @@ -960,10 +957,10 @@ _ (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (List/map ->Codec//decode g!vars)) + (-> (~@ (L/map ->Codec//decode g!vars)) (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars))))))))) base-parser (` ($_ ;;either - (~@ (List/join pattern-matching)))) + (~@ (L/join pattern-matching)))) parser (case g!vars #;Nil base-parser @@ -994,15 +991,15 @@ _ (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (List/map ->Codec//decode g!vars)) + (-> (~@ (L/map ->Codec//decode g!vars)) (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] (do R;Monad - [(~@ (List/join extraction))] - ((~ (' wrap)) (~ (code;record (List/map (function [[name :slot:]] - [(code;tag name) (code;symbol ["" (product;right name)])]) - members)))))) + [(~@ (L/join extraction))] + ((~ (' wrap)) (~ (code;record (L/map (function [[name :slot:]] + [(code;tag name) (code;symbol ["" (product;right name)])]) + members)))))) ))))) (with-gensyms [g!type-fun g!case g!input] (do @ @@ -1023,15 +1020,15 @@ _ (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (List/map ->Codec//decode g!vars)) + (-> (~@ (L/map ->Codec//decode g!vars)) (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))] #let [.decoder. (case g!vars #;Nil - (` (;;shape [(~@ (List/map product;right pattern-matching))])) + (` (;;shape [(~@ (L/map product;right pattern-matching))])) _ (` (function [(~@ g!vars)] - (;;shape [(~@ (List/map product;right pattern-matching))]))))]] + (;;shape [(~@ (L/map product;right pattern-matching))]))))]] (wrap (` (: (~ :x:+) (~ .decoder.)))) )) (do @ -- cgit v1.2.3