diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/predicate.lux | 5 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/array.lux | 23 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/row.lux | 31 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/set.lux | 7 | ||||
| -rw-r--r-- | stdlib/source/lux/language/compiler/synthesis.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/language/compiler/translation.lux | 114 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/collection/row.lux | 6 |
7 files changed, 143 insertions, 53 deletions
diff --git a/stdlib/source/lux/control/predicate.lux b/stdlib/source/lux/control/predicate.lux index 72fe8165f..1d683bf5a 100644 --- a/stdlib/source/lux/control/predicate.lux +++ b/stdlib/source/lux/control/predicate.lux @@ -1,7 +1,6 @@ (.module: [lux #* [control [monoid (#+ Monoid)]] - [data [collection [set (#+ Set)]]] [function]]) (type: #export (Predicate a) @@ -41,10 +40,6 @@ (and (base value) (not (sub value))))) -(def: #export (set set) - (All [a] (-> (Set a) (Predicate a))) - (set.member? set)) - (def: #export (rec predicate) (All [a] (-> (-> (Predicate a) (Predicate a)) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index a4fe01a35..7093de9a1 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -4,7 +4,8 @@ [monoid (#+ Monoid)] [functor (#+ Functor)] [equivalence (#+ Equivalence)] - fold] + fold + [predicate (#+ Predicate)]] [data [collection [list ("list/" Fold<List>)]] [product]] @@ -211,3 +212,23 @@ (#.Some value) (recur (f value so-far) (inc idx))) so-far))))) + +(do-template [<name> <init> <op>] + [(def: #export (<name> predicate array) + (All [a] + (-> (Predicate a) (Array a) Bit)) + (let [size (..size array)] + (loop [idx +0] + (if (n/< size idx) + (case (..read idx array) + (#.Some value) + (<op> (predicate value) + (recur (inc idx))) + + #.None + (recur (inc idx))) + <init>))))] + + [every? #1 and] + [any? #0 or] + ) diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux index 7ae37ebea..23e5ded20 100644 --- a/stdlib/source/lux/data/collection/row.lux +++ b/stdlib/source/lux/data/collection/row.lux @@ -7,7 +7,8 @@ [equivalence (#+ Equivalence)] monoid fold - ["p" parser]] + ["p" parser] + [predicate (#+ Predicate)]] [data [maybe] [product] @@ -15,7 +16,7 @@ [i64]] [collection [list ("list/" Fold<List> Functor<List> Monoid<List>)] - [array ("array/" Functor<Array> Fold<Array>)]]] + ["." array ("array/" Functor<Array> Fold<Array>)]]] [macro (#+ with-gensyms) [code] ["s" syntax (#+ syntax: Syntax)]] @@ -434,8 +435,30 @@ (^open) Monoid<Row>] (fold (function (_ post pre) (compose pre post)) identity)))) -(def: #export (reverse xs) +(def: #export reverse (All [a] (-> (Row a) (Row a))) (let [(^open) Fold<Row> (^open) Monoid<Row>] - (fold add identity xs))) + (fold add identity))) + +(do-template [<name> <array> <init> <op>] + [(def: #export <name> + (All [a] + (-> (Predicate a) (Row a) Bit)) + (let [help (: (All [a] + (-> (Predicate a) (Node a) Bit)) + (function (help predicate node) + (case node + (#Base base) + (<array> predicate base) + + (#Hierarchy hierarchy) + (<array> (help predicate) hierarchy))))] + (function (<name> predicate row) + (let [(^slots [#root #tail]) row] + (<op> (help predicate (#Hierarchy root)) + (help predicate (#Base tail)))))))] + + [every? array.every? #1 and] + [any? array.any? #0 or] + ) diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux index 11381c683..d78ae6d19 100644 --- a/stdlib/source/lux/data/collection/set.lux +++ b/stdlib/source/lux/data/collection/set.lux @@ -2,7 +2,8 @@ [lux #* [control [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] + [hash (#+ Hash)] + [predicate (#+ Predicate)]] [data [collection ["dict" dictionary (#+ Dictionary)] @@ -82,3 +83,7 @@ (def: #export (super? sub super) (All [a] (-> (Set a) (Set a) Bit)) (sub? super sub)) + +(def: #export predicate + (All [a] (-> (Set a) (Predicate a))) + ..member?) diff --git a/stdlib/source/lux/language/compiler/synthesis.lux b/stdlib/source/lux/language/compiler/synthesis.lux index 3d6762342..baea48c30 100644 --- a/stdlib/source/lux/language/compiler/synthesis.lux +++ b/stdlib/source/lux/language/compiler/synthesis.lux @@ -227,6 +227,16 @@ [variable/foreign reference.foreign] ) +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + + [variable reference.variable] + [constant reference.constant] + ) + (do-template [<name> <family> <tag>] [(template: #export (<name> content) (.<| #..Control diff --git a/stdlib/source/lux/language/compiler/translation.lux b/stdlib/source/lux/language/compiler/translation.lux index 077076d2f..b822d3cf8 100644 --- a/stdlib/source/lux/language/compiler/translation.lux +++ b/stdlib/source/lux/language/compiler/translation.lux @@ -4,8 +4,9 @@ ["ex" exception (#+ exception:)] [monad (#+ do)]] [data - [maybe ("maybe/" Functor<Maybe>)] + [product] [error (#+ Error)] + [ident ("ident/" Equivalence<Ident> Codec<Text,Ident>)] ["." text format] [collection @@ -28,46 +29,58 @@ (exception: #export (cannot-interpret {message Text}) message) +(do-template [<name>] + [(exception: #export (<name> {name Ident}) + (ex.report ["Artifact" (ident/encode name)]))] + + [cannot-overwrite-artifact] + [no-buffer-for-saving-code] + ) + (type: #export Context {#scope-name Text #inner-functions Nat}) -(signature: #export (Host code) - (: (-> code (Error Any)) - execute!) - (: (-> code (Error Any)) - evaluate!)) +(signature: #export (Host expression statement) + (: (-> expression (Error Any)) + evaluate!) + (: (-> statement (Error Any)) + execute!)) -(type: #export (Buffer code) (Row [Ident code])) +(type: #export (Buffer statement) (Row [Ident statement])) -(type: #export (Artifacts code) (Dictionary File (Buffer code))) +(type: #export (Artifacts statement) (Dictionary File (Buffer statement))) -(type: #export (State anchor code) +(type: #export (State anchor expression statement) {#context Context #anchor (Maybe anchor) - #host (Host code) - #buffer (Maybe (Buffer code)) - #artifacts (Artifacts code)}) + #host (Host expression statement) + #buffer (Maybe (Buffer statement)) + #artifacts (Artifacts statement) + #counter Nat}) -(type: #export (Operation anchor code) - (extension.Operation (State anchor code) Synthesis code)) +(type: #export (Operation anchor expression statement) + (extension.Operation (State anchor expression statement) Synthesis expression)) -(type: #export (Compiler anchor code) - (extension.Compiler (State anchor code) Synthesis code)) +(type: #export (Compiler anchor expression statement) + (extension.Compiler (State anchor expression statement) Synthesis expression)) (def: #export (init host) - (All [anchor code] (-> (Host code) (..State anchor code))) + (All [anchor expression statement] + (-> (Host expression statement) + (..State anchor expression statement))) {#context {#scope-name "" #inner-functions +0} #anchor #.None #host host #buffer #.None - #artifacts (dict.new text.Hash<Text>)}) + #artifacts (dict.new text.Hash<Text>) + #counter +0}) (def: #export (with-context expr) - (All [anchor code output] - (-> (Operation anchor code output) - (Operation anchor code [Text output]))) + (All [anchor expression statement output] + (-> (Operation anchor expression statement output) + (Operation anchor expression statement [Text output]))) (function (_ [bundle state]) (let [[old-scope old-inner] (get@ #context state) new-scope (format old-scope "c___" (%i (.int old-inner)))] @@ -80,7 +93,8 @@ (#error.Error error))))) (def: #export context - (All [anchor code] (Operation anchor code Text)) + (All [anchor expression statement] + (Operation anchor expression statement Text)) (extension.read (|>> (get@ #context) (get@ #scope-name)))) @@ -88,7 +102,7 @@ <with-declaration> <with-type> <with-value> <get> <get-type> <exception>] [(def: #export <with-declaration> - (All [anchor code output] <with-type>) + (All [anchor expression statement output] <with-type>) (function (_ body) (function (_ [bundle state]) (case (body [bundle (set@ <tag> (#.Some <with-value>) state)]) @@ -100,7 +114,8 @@ (#error.Error error))))) (def: #export <get> - (All [anchor code] (Operation anchor code <get-type>)) + (All [anchor expression statement] + (Operation anchor expression statement <get-type>)) (function (_ (^@ stateE [bundle state])) (case (get@ <tag> state) (#.Some output) @@ -111,28 +126,35 @@ [#anchor (with-anchor anchor) - (-> anchor (Operation anchor code output) - (Operation anchor code output)) + (-> anchor (Operation anchor expression statement output) + (Operation anchor expression statement output)) anchor anchor anchor no-anchor] [#buffer with-buffer - (-> (Operation anchor code output) - (Operation anchor code output)) + (-> (Operation anchor expression statement output) + (Operation anchor expression statement output)) row.empty - buffer (Buffer code) no-active-buffer] + buffer (Buffer statement) no-active-buffer] ) (def: #export artifacts - (All [anchor code] - (Operation anchor code (Artifacts code))) + (All [anchor expression statement] + (Operation anchor expression statement (Artifacts statement))) (extension.read (get@ #artifacts))) -(do-template [<name>] +(def: #export next + (All [anchor expression statement] + (Operation anchor expression statement Nat)) + (do //.Monad<Operation> + [_ (extension.update (update@ #counter inc))] + (extension.read (get@ #counter)))) + +(do-template [<name> <inputT>] [(def: #export (<name> code) - (All [anchor code] - (-> code (Operation anchor code Any))) + (All [anchor expression statement] + (-> <inputT> (Operation anchor expression statement Any))) (function (_ (^@ stateE [bundle state])) (case (:: (get@ #host state) <name> code) (#error.Error error) @@ -141,20 +163,28 @@ (#error.Success output) (#error.Success [stateE output]))))] - [execute!] - [evaluate!] + [evaluate! expression] + [execute! statement] ) (def: #export (save! name code) - (All [anchor code] - (-> Ident code (Operation anchor code Any))) + (All [anchor expression statement] + (-> Ident statement (Operation anchor expression statement Any))) (do //.Monad<Operation> - [_ (execute! code)] - (extension.update (update@ #buffer (maybe/map (row.add [name code])))))) + [_ (execute! code) + ?buffer (extension.read (get@ #buffer))] + (case ?buffer + (#.Some buffer) + (if (row.any? (|>> product.left (ident/= name)) buffer) + (//.throw cannot-overwrite-artifact name) + (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) + + #.None + (//.throw no-buffer-for-saving-code name)))) (def: #export (save-buffer! target) - (All [anchor code] - (-> File (Operation anchor code Any))) + (All [anchor expression statement] + (-> File (Operation anchor expression statement Any))) (do //.Monad<Operation> [buffer ..buffer] (extension.update (update@ #artifacts (dict.put target buffer))))) diff --git a/stdlib/test/test/lux/data/collection/row.lux b/stdlib/test/test/lux/data/collection/row.lux index f8850447a..dbe9280b6 100644 --- a/stdlib/test/test/lux/data/collection/row.lux +++ b/stdlib/test/test/lux/data/collection/row.lux @@ -73,4 +73,10 @@ (test "Row concatenation is a monad." (&/= (&/compose sample other-sample) (&/join (&.row sample other-sample)))) + + (test "Can reverse." + (and (not (&/= sample + (&.reverse sample))) + (not (&/= sample + (&.reverse (&.reverse sample)))))) )))) |