From 73120f5cc97224c2a5c961b4aa881738cc78e2af Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Dec 2018 19:10:43 -0400 Subject: Some refactoring. --- stdlib/source/lux.lux | 6 +- stdlib/source/lux/cli.lux | 12 +- stdlib/source/lux/concurrency/task.lux | 60 +++--- stdlib/source/lux/data/collection/dictionary.lux | 13 +- stdlib/source/lux/data/format/json.lux | 264 ++++++++++++----------- stdlib/source/lux/data/text/format.lux | 2 - stdlib/source/lux/data/text/lexer.lux | 20 +- 7 files changed, 201 insertions(+), 176 deletions(-) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 1fb0afe19..fafecd7ad 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -471,7 +471,7 @@ #Nil))) (record$ #Nil)) -("lux def" default-def-meta-unexported +("lux def" default-def-meta-private ("lux check" (#Apply (#Product Code Code) List) (#Cons [(tag$ ["lux" "type?"]) (bit$ #1)] @@ -540,7 +540,7 @@ ("lux def" Code-List (#Apply Code List) - (record$ default-def-meta-unexported)) + (record$ default-def-meta-private)) ## (type: (Either l r) ## (#Left l) @@ -1626,7 +1626,7 @@ (def:''' Monad (list& [(tag$ ["lux" "tags"]) (tuple$ (list (text$ "wrap") (text$ "bind")))] - default-def-meta-unexported) + default-def-meta-private) Type (#Named ["lux" "Monad"] (All [m] diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index 07e79d86f..043519111 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -96,9 +96,15 @@ #.Nil (#E.Success [inputs []]) _ (#E.Error (format "Unknown parameters: " (text.join-with " " inputs)))))) -(def: #export (parameter [short long]) - (-> [Text Text] (CLI Text)) - (|> ..any +(def: #export (named name value) + (All [a] (-> Text (CLI a) (CLI a))) + (|> value + (p.after (..this name)) + ..somewhere)) + +(def: #export (parameter [short long] value) + (All [a] (-> [Text Text] (CLI a) (CLI a))) + (|> value (p.after (p.either (..this short) (..this long))) ..somewhere)) diff --git a/stdlib/source/lux/concurrency/task.lux b/stdlib/source/lux/concurrency/task.lux index f3043ce9b..c03ab7647 100644 --- a/stdlib/source/lux/concurrency/task.lux +++ b/stdlib/source/lux/concurrency/task.lux @@ -1,55 +1,57 @@ (.module: [lux #* - [data ["E" error]] [control - ["F" functor] - ["A" apply] - monad + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] ["ex" exception (#+ Exception)]] - [concurrency ["P" promise]] - ["." macro ["s" syntax (#+ syntax: Syntax)]] - ]) + [data + ["." error (#+ Error)]] + ["." macro + ["s" syntax (#+ syntax: Syntax)]]] + [// + ["." promise (#+ Promise)]]) (type: #export (Task a) - (P.Promise (E.Error a))) + (Promise (Error a))) (def: #export (fail error) (All [a] (-> Text (Task a))) - (:: P.Monad wrap (#E.Error error))) + (:: promise.Monad wrap (#error.Error error))) (def: #export (throw exception message) (All [e a] (-> (Exception e) e (Task a))) - (:: P.Monad wrap + (:: promise.Monad wrap (ex.throw exception message))) (def: #export (return value) (All [a] (-> a (Task a))) - (:: P.Monad wrap (#E.Success value))) + (:: promise.Monad wrap (#error.Success value))) (def: #export (try computation) - (All [a] (-> (Task a) (Task (E.Error a)))) - (:: P.Functor map (|>> #E.Success) computation)) + (All [a] (-> (Task a) (Task (Error a)))) + (:: promise.Functor map (|>> #error.Success) computation)) -(structure: #export _ (F.Functor Task) +(structure: #export _ (Functor Task) (def: (map f fa) - (:: P.Functor map + (:: promise.Functor map (function (_ fa') (case fa' - (#E.Error error) - (#E.Error error) + (#error.Error error) + (#error.Error error) - (#E.Success a) - (#E.Success (f a)))) + (#error.Success a) + (#error.Success (f a)))) fa))) -(structure: #export _ (A.Apply Task) +(structure: #export _ (Apply Task) (def: functor Functor) (def: (apply ff fa) - (do P.Monad + (do promise.Monad [ff' ff fa' fa] - (wrap (do E.Monad + (wrap (do error.Monad [f ff' a fa'] (wrap (f a))))))) @@ -60,21 +62,21 @@ (def: wrap return) (def: (join mma) - (do P.Monad + (do promise.Monad [mma' mma] (case mma' - (#E.Error error) - (wrap (#E.Error error)) + (#error.Error error) + (wrap (#error.Error error)) - (#E.Success ma) + (#error.Success ma) ma)))) (syntax: #export (task {type s.any}) {#.doc (doc "Makes an uninitialized Task (in this example, of Any)." (task Any))} (wrap (list (` (: (..Task (~ type)) - (P.promise #.None)))))) + (promise.promise #.None)))))) (def: #export (from-promise promise) - (All [a] (-> (P.Promise a) (Task a))) - (:: P.Functor map (|>> #E.Success) promise)) + (All [a] (-> (Promise a) (Task a))) + (:: promise.Functor map (|>> #error.Success) promise)) diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux index 503ea312d..b0f0920fb 100644 --- a/stdlib/source/lux/data/collection/dictionary.lux +++ b/stdlib/source/lux/data/collection/dictionary.lux @@ -569,12 +569,12 @@ #.None #0 (#.Some _) #1)) -(def: #export (put~ key val dict) +(def: #export (try-put key val dict) {#.doc "Only puts the KV-pair if the key is not already present."} (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) - (if (contains? key dict) - dict - (put key val dict))) + (case (get key dict) + #.None (put key val dict) + (#.Some _) dict)) (def: #export (update key f dict) {#.doc "Transforms the value located at key (if available), using the given function."} @@ -586,8 +586,9 @@ (#.Some val) (put key (f val) dict))) -(def: #export (update~ key default f dict) - {#.doc "Transforms the value located at key (if available), using the given function."} +(def: #export (upsert key default f dict) + {#.doc (doc "Updates the value at the key; if it exists." + "Otherwise, puts a value by applying the function to a default.")} (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v))) (put key (f (maybe.default default diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 20f059503..63075804e 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -5,11 +5,12 @@ ["." monad (#+ do Monad)] [equivalence (#+ Equivalence)] codec - ["p" parser ("parser/." Monad)]] + ["p" parser ("parser/." Monad)] + ["ex" exception (#+ exception:)]] [data ["." bit] ["." maybe] - ["e" error] + ["." error (#+ Error)] ["." sum] ["." product] ["." number ("frac/." Codec) ("nat/." Codec)] @@ -18,7 +19,7 @@ [collection ["." list ("list/." Fold Monad)] ["." row (#+ Row row) ("row/." Monad)] - ["dict" dictionary (#+ Dictionary)]]] + ["." dictionary (#+ Dictionary)]]] ["." macro (#+ Monad with-gensyms) ["s" syntax (#+ syntax:)] ["." code]]]) @@ -87,7 +88,7 @@ _ (macro.fail "Wrong syntax for JSON object."))) pairs)] - (wrap (list (` (: JSON (#Object (dict.from-list text.Hash (list (~+ pairs'))))))))) + (wrap (list (` (: JSON (#Object (dictionary.from-list text.Hash (list (~+ pairs'))))))))) _ (wrap (list token)) @@ -95,52 +96,52 @@ (def: #export (get-fields json) {#.doc "Get all the fields in a JSON object."} - (-> JSON (e.Error (List String))) + (-> JSON (Error (List String))) (case json (#Object obj) - (#e.Success (dict.keys obj)) + (#error.Success (dictionary.keys obj)) _ - (#e.Error ($_ text/compose "Cannot get the fields of a non-object.")))) + (#error.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)) + (-> String JSON (Error JSON)) (case json (#Object obj) - (case (dict.get key obj) + (case (dictionary.get key obj) (#.Some value) - (#e.Success value) + (#error.Success value) #.None - (#e.Error ($_ text/compose "Missing field '" key "' on object."))) + (#error.Error ($_ text/compose "Missing field '" key "' on object."))) _ - (#e.Error ($_ text/compose "Cannot get field '" key "' of a non-object.")))) + (#error.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)) + (-> String JSON JSON (Error JSON)) (case json (#Object obj) - (#e.Success (#Object (dict.put key value obj))) + (#error.Success (#Object (dictionary.put key value obj))) _ - (#e.Error ($_ text/compose "Cannot set field '" key "' of a non-object.")))) + (#error.Error ($_ text/compose "Cannot set field '" key "' of a non-object.")))) (do-template [ ] [(def: #export ( key json) {#.doc (code.text ($_ text/compose "A JSON object field getter for " "."))} - (-> Text JSON (e.Error )) + (-> Text JSON (Error )) (case (get key json) - (#e.Success ( value)) - (#e.Success value) + (#error.Success ( value)) + (#error.Success value) - (#e.Success _) - (#e.Error ($_ text/compose "Wrong value type at key: " key)) + (#error.Success _) + (#error.Error ($_ text/compose "Wrong value type at key: " key)) - (#e.Error error) - (#e.Error error)))] + (#error.Error error) + (#error.Error error)))] [get-boolean #Boolean Boolean "booleans"] [get-number #Number Number "numbers"] @@ -175,14 +176,14 @@ (list.indices (row.size xs)))) [(#Object xs) (#Object ys)] - (and (n/= (dict.size xs) (dict.size ys)) + (and (n/= (dictionary.size xs) (dictionary.size ys)) (list/fold (function (_ [xk xv] prev) (and prev - (case (dict.get xk ys) + (case (dictionary.get xk ys) #.None #0 (#.Some yv) (= xv yv)))) #1 - (dict.entries xs))) + (dictionary.entries xs))) _ #0))) @@ -191,26 +192,79 @@ ############################################################ ############################################################ -(def: unconsumed-input-error Text "Unconsumed JSON.") +(def: (encode-boolean value) + (-> Bit Text) + (case value + #0 "false" + #1 "true")) + +(def: (show-null _) (-> Null Text) "null") +(do-template [ ] + [(def: (-> Text) )] + + [show-boolean Boolean encode-boolean] + [show-number Number (:: number.Codec 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 + dictionary.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 [ ] + ( value) + ( value)) + ([#Null show-null] + [#Boolean show-boolean] + [#Number show-number] + [#String show-string] + [#Array (show-array show-json)] + [#Object (show-object show-json)]) + )) + +############################################################ +############################################################ +############################################################ + +(exception: #export (unconsumed-input {input (List JSON)}) + (|> input + (list/map show-json) + (text.join-with text.new-line))) + +(exception: #export (empty-input) + "") (def: #export (run json parser) - (All [a] (-> JSON (Reader a) (e.Error a))) + (All [a] (-> JSON (Reader a) (Error a))) (case (p.run (list json) parser) - (#e.Success [remainder output]) + (#error.Success [remainder output]) (case remainder #.Nil - (#e.Success output) + (#error.Success output) _ - (#e.Error unconsumed-input-error)) + (ex.throw unconsumed-input remainder)) - (#e.Error error) - (#e.Error error))) + (#error.Error error) + (#error.Error error))) (def: #export (fail error) (All [a] (-> Text (Reader a))) (function (_ inputs) - (#e.Error error))) + (#error.Error error))) (def: #export any {#.doc "Just returns the JSON input without applying any logic."} @@ -218,10 +272,10 @@ (<| (function (_ inputs)) (case inputs #.Nil - (#e.Error "Empty JSON stream.") + (ex.throw empty-input []) (#.Cons head tail) - (#e.Success [tail head])))) + (#error.Success [tail head])))) (do-template [ ] [(def: #export @@ -242,12 +296,6 @@ [string Text #String "string"] ) -(def: (encode-boolean value) - (-> Bit Text) - (if value - "true" - "false")) - (do-template [ 
]
   [(def: #export ( test)
      {#.doc (code.text ($_ text/compose "Asks whether a JSON value is a "  "."))}
@@ -271,7 +319,7 @@
          (let [value (
 value)]
            (if (::  = test value)
              (wrap [])
-             (fail ($_ text/compose "Value mismatch: " ( test) "=/=" ( value)))))
+             (fail ($_ text/compose "Value mismatch: " ( test) " =/= " ( value)))))
 
          _
          (fail ($_ text/compose "JSON value is not a "  ".")))))]
@@ -287,117 +335,85 @@
         parser))
 
 (def: #export (array parser)
-  {#.doc "Parses a JSON array, assuming that every element can be parsed the same way."}
+  {#.doc "Parses a JSON array."}
   (All [a] (-> (Reader a) (Reader a)))
   (do p.Monad
     [head any]
     (case head
       (#Array values)
       (case (p.run (row.to-list values) parser)
-        (#e.Error error)
+        (#error.Error error)
         (fail error)
 
-        (#e.Success [remainder output])
+        (#error.Success [remainder output])
         (case remainder
           #.Nil
           (wrap output)
 
           _
-          (fail unconsumed-input-error)))
+          (fail (ex.construct unconsumed-input remainder))))
 
       _
-      (fail "JSON value is not an array."))))
+      (fail (text/compose "JSON value is not an array: " (show-json head))))))
 
 (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))))
+  {#.doc "Parses a JSON object. Use this with the 'field' combinator."}
+  (All [a] (-> (Reader a) (Reader a)))
   (do p.Monad
     [head any]
     (case head
-      (#Object object)
-      (case (do e.Monad
-              []
-              (|> (dict.entries object)
-                  (monad.map @ (function (_ [key val])
-                                 (do @
-                                   [val (run val parser)]
-                                   (wrap [key val]))))
-                  (:: @ map (dict.from-list text.Hash))))
-        (#e.Success table)
-        (wrap table)
-
-        (#e.Error error)
-        (fail error))
+      (#Object kvs)
+      (case (p.run (|> kvs
+                       dictionary.entries
+                       (list/map (function (_ [key value])
+                                   (list (#String key) value)))
+                       list.concat)
+                   parser)
+        (#error.Error error)
+        (fail error)
+
+        (#error.Success [remainder output])
+        (case remainder
+          #.Nil
+          (wrap output)
 
+          _
+          (fail (ex.construct unconsumed-input remainder))))
+      
       _
-      (fail "JSON value is not an array."))))
+      (fail (text/compose "JSON value is not an object: " (show-json head))))))
 
 (def: #export (field field-name parser)
-  {#.doc "Parses a field inside a JSON object."}
+  {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
   (All [a] (-> Text (Reader a) (Reader a)))
-  (do p.Monad
-    [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 "'.")))
+  (function (recur inputs)
+    (case inputs
+      (^ (list& (#String key) value inputs'))
+      (if (text/= key field-name)
+        (case (p.run (list value) parser)
+          (#error.Success [#.Nil output])
+          (#error.Success [inputs' output])
+
+          (#error.Success [inputs'' _])
+          (ex.throw unconsumed-input inputs'')
+
+          (#error.Error error)
+          (#error.Error error))
+        (do error.Monad
+          [[inputs'' output] (recur inputs')]
+          (wrap [(list& (#String key) value inputs'')
+                 output])))
+
+      #.Nil
+      (ex.throw empty-input [])
 
       _
-      (fail "JSON value is not an object."))))
+      (ex.throw unconsumed-input inputs))))
 
 ############################################################
 ############################################################
 ############################################################
 
-(def: (show-null _) (-> Null Text) "null")
-(do-template [  ]
-  [(def:  (->  Text) )]
-
-  [show-boolean Boolean encode-boolean]
-  [show-number  Number (:: number.Codec 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 [ ]
-      ( 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))
@@ -443,10 +459,10 @@
                        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)
+      (#error.Error message)
       (p.fail message)
       
-      (#e.Success value)
+      (#error.Success value)
       (wrap value))))
 
 (def: escaped~
@@ -503,7 +519,7 @@
        (wrap ( elems))))]
 
   [array~  Array  "[" "]" (json~ [])  row.from-list]
-  [object~ Object "{" "}" (kv~ json~) (dict.from-list text.Hash)]
+  [object~ Object "{" "}" (kv~ json~) (dictionary.from-list text.Hash)]
   )
 
 (def: (json~' _)
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index 02c3eaae2..ad0653e76 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -15,7 +15,6 @@
      [list ("list/." Monad)]]]
    [time
     ["." instant]
-    ["." duration]
     ["." date]]
    [math
     ["." modular]]
@@ -55,7 +54,6 @@
   [%xml      xml.XML           (:: xml.Codec encode)]
   [%json     json.JSON         (:: json.Codec encode)]
   [%instant  instant.Instant   instant.to-text]
-  [%duration duration.Duration (:: duration.Codec encode)]
   [%date     date.Date         (:: date.Codec encode)]
   )
 
diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux
index 21aba8360..45a88bdf3 100644
--- a/stdlib/source/lux/data/text/lexer.lux
+++ b/stdlib/source/lux/data/text/lexer.lux
@@ -2,11 +2,13 @@
   [lux (#- or and not)
    [control
     [monad (#+ do Monad)]
-    ["p" parser]]
+    ["p" parser]
+    ["ex" exception (#+ exception:)]]
    [data
     ["." product]
     ["." maybe]
     ["e" error]
+    [number ("nat/." Codec)]
     [collection
      ["." list ("list/." Fold)]]]
    [macro
@@ -24,15 +26,16 @@
   {#basis Offset
    #distance Offset})
 
+(def: cannot-lex-error Text "Cannot lex from empty text.")
+
 (def: (remaining offset tape)
   (-> Offset Text Text)
   (|> tape (//.split offset) maybe.assume product.right))
 
-(def: cannot-lex-error Text "Cannot lex from empty text.")
-
-(def: (unconsumed-input-error offset tape)
-  (-> Offset Text Text)
-  ($_ text/compose "Unconsumed input: " (remaining offset tape)))
+(exception: #export (unconsumed-input {offset Offset} {tape Text})
+  (ex.report ["Offset" (nat/encode offset)]
+             ["Input size" (nat/encode (//.size tape))]
+             ["Remaining input" (remaining offset tape)]))
 
 (def: #export (run input lexer)
   (All [a] (-> Text (Lexer a) (e.Error a)))
@@ -43,8 +46,7 @@
     (#e.Success [[end-offset _] output])
     (if (n/= end-offset (//.size input))
       (#e.Success output)
-      (#e.Error (unconsumed-input-error end-offset input)))
-    ))
+      (ex.throw unconsumed-input [end-offset input]))))
 
 (def: #export offset
   (Lexer Offset)
@@ -130,7 +132,7 @@
   (function (_ (^@ input [offset tape]))
     (if (n/= offset (//.size tape))
       (#e.Success [input []])
-      (#e.Error (unconsumed-input-error offset tape)))))
+      (ex.throw unconsumed-input [offset tape]))))
 
 (def: #export end?
   {#.doc "Ask if the lexer's input is empty."}
-- 
cgit v1.2.3