From c9db1d195fc45ab296e11ab63e428d53708ab689 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Apr 2017 20:10:14 -0400 Subject: - :: can now be used to refer to sub-structures within a structure. --- stdlib/source/lux.lux | 85 +++++++++++++++++++-------------- stdlib/source/lux/control/interval.lux | 8 ++-- stdlib/source/lux/data/coll/ordered.lux | 2 +- stdlib/source/lux/data/coll/queue.lux | 2 +- stdlib/source/lux/function/state.lux | 3 +- 5 files changed, 57 insertions(+), 43 deletions(-) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index bac65ef16..541b4bcdc 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2244,11 +2244,11 @@ "-")] ((_lux_: (-> Int Text Text) (lambda' recur [input output] - (if (i.= 0 input) - (_lux_proc ["text" "append"] [sign output]) - (recur (i./ 10 input) - (_lux_proc ["text" "append"] [(|> input (i.% 10) (_lux_:! Nat) digit-to-text) - output]))))) + (if (i.= 0 input) + (_lux_proc ["text" "append"] [sign output]) + (recur (i./ 10 input) + (_lux_proc ["text" "append"] [(|> input (i.% 10) (_lux_:! Nat) digit-to-text) + output]))))) (|> value (i./ 10) Int/abs) (|> value (i.% 10) Int/abs (_lux_:! Nat) digit-to-text))))) @@ -4204,24 +4204,6 @@ _ (list))) -(def: (use-field prefix [module name] type) - (-> Text Ident Type (Lux [AST AST])) - (do Monad - [output (resolve-type-tags type) - pattern (: (Lux AST) - (case output - (#Some [tags members]) - (do Monad - [slots (mapM Monad - (: (-> [Ident Type] (Lux [AST AST])) - (lambda [[sname stype]] (use-field prefix sname stype))) - (zip2 tags members))] - (return (record$ slots))) - - #None - (return (symbol$ ["" (Text/append prefix name)]))))] - (return [(tag$ [module name]) pattern]))) - (def: (Type/show type) (-> Type Text) (case type @@ -4270,23 +4252,56 @@ ($_ Text/append prefix ";" name) )) +(def: (foldM Monad f init inputs) + (All [m o i] + (-> (Monad m) (-> i o (m o)) o (List i) (m o))) + (case inputs + #;Nil + (do Monad + [] + (wrap init)) + + (#;Cons input inputs') + (do Monad + [output (f input init)] + (foldM Monad f output inputs')))) + (macro: #hidden (^open' tokens) (case tokens (^ (list [_ (#SymbolS name)] [_ (#TextS prefix)] body)) (do Monad - [struct-type (find-type name) - output (resolve-type-tags struct-type)] - (case output - (#Some [tags members]) - (do Monad - [slots (mapM Monad (: (-> [Ident Type] (Lux [AST AST])) - (lambda [[sname stype]] (use-field prefix sname stype))) - (zip2 tags members)) - #let [pattern (record$ slots)]] - (return (list (` (;_lux_case (~ (symbol$ name)) (~ pattern) (~ body)))))) + [init-type (find-type name) + struct-evidence (resolve-type-tags init-type)] + (case struct-evidence + #;None + (fail (Text/append "Can only \"open\" structs: " (Type/show init-type))) - _ - (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type))))) + (#;Some tags&members) + (do Monad + [full-body ((: (-> Ident [(List Ident) (List Type)] AST (Lux AST)) + (lambda recur [source [tags members] target] + (let [pattern (record$ (map (lambda [[t-module t-name]] + [(tag$ [t-module t-name]) + (symbol$ ["" (Text/append prefix t-name)])]) + tags))] + (do Monad + [enhanced-target (foldM Monad + (lambda [[[_ m-name] m-type] enhanced-target] + (do Monad + [m-structure (resolve-type-tags m-type)] + (case m-structure + (#;Some m-tags&members) + (recur ["" (Text/append prefix m-name)] + m-tags&members + enhanced-target) + + #;None + (wrap enhanced-target)))) + target + (zip2 tags members))] + (wrap (` (;_lux_case (~ (symbol$ source)) (~ pattern) (~ enhanced-target)))))))) + name tags&members body)] + (wrap (list full-body))))) _ (fail "Wrong syntax for ^open"))) diff --git a/stdlib/source/lux/control/interval.lux b/stdlib/source/lux/control/interval.lux index c007477b4..673ad630f 100644 --- a/stdlib/source/lux/control/interval.lux +++ b/stdlib/source/lux/control/interval.lux @@ -72,14 +72,14 @@ (def: #export (union left right) (All [a] (-> (Interval a) (Interval a) (Interval a))) (struct (def: enum (get@ #enum right)) - (def: bottom (order;min (get@ [#enum #enum;order] right) (:: left bottom) (:: right bottom))) - (def: top (order;max (get@ [#enum #enum;order] right) (:: left top) (:: right top))))) + (def: bottom (order;min (:: right order) (:: left bottom) (:: right bottom))) + (def: top (order;max (:: right order) (:: left top) (:: right top))))) (def: #export (intersection left right) (All [a] (-> (Interval a) (Interval a) (Interval a))) (struct (def: enum (get@ #enum right)) - (def: bottom (order;max (get@ [#enum #enum;order] right) (:: left bottom) (:: right bottom))) - (def: top (order;min (get@ [#enum #enum;order] right) (:: left top) (:: right top))))) + (def: bottom (order;max (:: right order) (:: left bottom) (:: right bottom))) + (def: top (order;min (:: right order) (:: left top) (:: right top))))) (def: #export (complement interval) (All [a] (-> (Interval a) (Interval a))) diff --git a/stdlib/source/lux/data/coll/ordered.lux b/stdlib/source/lux/data/coll/ordered.lux index 37fbb1505..568a3f1be 100644 --- a/stdlib/source/lux/data/coll/ordered.lux +++ b/stdlib/source/lux/data/coll/ordered.lux @@ -489,5 +489,5 @@ (struct: #export Eq (All [a] (Eq (Set a))) (def: (= reference sample) - (:: (list;Eq (get@ [#order #order;eq] sample)) + (:: (list;Eq (:: sample eq)) = (to-list reference) (to-list sample)))) diff --git a/stdlib/source/lux/data/coll/queue.lux b/stdlib/source/lux/data/coll/queue.lux index 03d40b020..520211dca 100644 --- a/stdlib/source/lux/data/coll/queue.lux +++ b/stdlib/source/lux/data/coll/queue.lux @@ -36,7 +36,7 @@ (def: #export empty? (All [a] (-> (Queue a) Bool)) - (|>. (get@ [#front]) list;empty?)) + (|>. (get@ #front) list;empty?)) (def: #export (member? Eq queue member) (All [a] (-> (Eq a) (Queue a) a Bool)) diff --git a/stdlib/source/lux/function/state.lux b/stdlib/source/lux/function/state.lux index 5f5b96e4b..edca1d81b 100644 --- a/stdlib/source/lux/function/state.lux +++ b/stdlib/source/lux/function/state.lux @@ -83,8 +83,7 @@ (struct: (Applicative Monad) (All [M s] (-> (Monad M) (Applicative (All [a] (-> s (M [s a])))))) - (def: functor (Functor (get@ [#M;applicative #A;functor] - Monad))) + (def: functor (Functor (:: Monad functor))) (def: (wrap a) (lambda [state] -- cgit v1.2.3