diff options
Diffstat (limited to '')
25 files changed, 699 insertions, 312 deletions
diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux index 3828b6d83..584bf614e 100644 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ b/stdlib/source/lux/control/concurrency/actor.lux @@ -74,13 +74,12 @@ (type: #export (Behavior o s) {#.doc "An actor's behavior when mail is received and when a fatal error occurs."} {#on_init (-> o s) - #on_mail (-> (Mail s) s (Actor s) (Promise (Try s))) - #on_stop (-> Text s (Promise Any))}) + #on_mail (-> (Mail s) s (Actor s) (Promise (Try s)))}) (def: #export (spawn! behavior init) {#.doc "Given a behavior and initial state, spawns an actor and returns it."} (All [o s] (-> (Behavior o s) o (IO (Actor s)))) - (io (let [[on_init on_mail on_stop] behavior + (io (let [[on_init on_mail] behavior self (:share [o s] {(Behavior o s) behavior} @@ -94,14 +93,12 @@ ?state' (on_mail head state self)] (case ?state' (#try.Failure error) - (do ! - [_ (on_stop error state)] - (let [[_ resolve] (get@ #obituary (:representation self))] - (exec (io.run - (do io.monad - [pending (..pending tail)] - (resolve [error state (#.Cons head pending)]))) - (wrap [])))) + (let [[_ resolve] (get@ #obituary (:representation self))] + (exec (io.run + (do io.monad + [pending (..pending tail)] + (resolve [error state (#.Cons head pending)]))) + (wrap []))) (#try.Success state') (recur state' tail))))] @@ -199,15 +196,10 @@ (All [s] (-> (Mail s) s (Actor s) (Promise (Try s)))) (mail state self)) -(def: (default_on_stop cause state) - (All [s] (-> Text s (Promise Any))) - (promise\wrap [])) - (def: #export default (All [s] (Behavior s s)) {#on_init function.identity - #on_mail ..default_on_mail - #on_stop ..default_on_stop}) + #on_mail ..default_on_mail}) (def: #export (poison! actor) {#.doc (doc "Kills the actor by sending mail that will kill it upon processing," @@ -225,11 +217,8 @@ (type: On_MailC [[Text Text Text] Code]) -(type: On_StopC - [[Text Text] Code]) - (type: BehaviorC - [(Maybe On_MailC) (Maybe On_StopC) (List Code)]) + [(Maybe On_MailC) (List Code)]) (def: argument (Parser Text) @@ -237,13 +226,10 @@ (def: behavior^ (Parser BehaviorC) - (let [on_mail_args ($_ <>.and ..argument ..argument ..argument) - on_stop_args ($_ <>.and ..argument ..argument)] + (let [on_mail_args ($_ <>.and ..argument ..argument ..argument)] ($_ <>.and (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' on_mail)) on_mail_args)) <c>.any))) - (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' on_stop)) on_stop_args)) - <c>.any))) (<>.some <c>.any)))) (def: (on_mail g!_ ?on_mail) @@ -259,18 +245,6 @@ (~ (code.local_identifier selfN))) (~ bodyC))))) -(def: (on_stop g!_ ?on_stop) - (-> Code (Maybe On_StopC) Code) - (case ?on_stop - #.None - (` (~! ..default_on_stop)) - - (#.Some [[causeN stateN] bodyC]) - (` (function ((~ g!_) - (~ (code.local_identifier causeN)) - (~ (code.local_identifier stateN))) - (~ bodyC))))) - (with_expansions [<examples> (as_is (actor: #export (Stack a) (List a) @@ -288,12 +262,6 @@ (actor: #export Counter Nat - ((on_stop cause state) - (\ promise.monad wrap - (log! (if (exception.match? ..poisoned cause) - (format "Counter was poisoned: " (%.nat state)) - cause)))) - (message: #export (count! {increment Nat} state self Any) (let [state' (n.+ increment state)] (promise.resolved (#try.Success [state' state'])))) @@ -305,9 +273,9 @@ {[name vars] actor_decl^} {annotations (<>.default |annotations|.empty |annotations|.parser)} state_type - {[?on_mail ?on_stop messages] behavior^}) + {[?on_mail messages] behavior^}) {#.doc (doc "Defines an actor, with its behavior and internal state." - "Messages for the actor must be defined after the on_mail and on_stop handlers." + "Messages for the actor must be defined after the on_mail handler." <examples>)} (with_gensyms [g!_] (do meta.monad @@ -321,19 +289,17 @@ (All [(~+ g!vars)] (..Behavior (~ state_type) ((~ g!type) (~+ g!vars)))) {#..on_init (|>> ((~! abstract.:abstraction) (~ g!type))) - #..on_mail (~ (..on_mail g!_ ?on_mail)) - #..on_stop (~ (..on_stop g!_ ?on_stop))}) + #..on_mail (~ (..on_mail g!_ ?on_mail))}) (~+ messages)))))))) (syntax: #export (actor {[state_type init] (<c>.record (<>.and <c>.any <c>.any))} - {[?on_mail ?on_stop messages] behavior^}) + {[?on_mail messages] behavior^}) (with_gensyms [g!_] (wrap (list (` (: ((~! io.IO) (..Actor (~ state_type))) (..spawn! (: (..Behavior (~ state_type) (~ state_type)) {#..on_init (|>>) - #..on_mail (~ (..on_mail g!_ ?on_mail)) - #..on_stop (~ (..on_stop g!_ ?on_stop))}) + #..on_mail (~ (..on_mail g!_ ?on_mail))}) (: (~ state_type) (~ init))))))))) diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux index 3b9732ae5..a9d9144b8 100644 --- a/stdlib/source/lux/control/parser/xml.lux +++ b/stdlib/source/lux/control/parser/xml.lux @@ -38,8 +38,8 @@ (def: #export text (Parser Text) - (function (_ docs) - (case docs + (function (_ documents) + (case documents #.Nil (exception.throw ..empty_input []) @@ -53,8 +53,8 @@ (def: #export (node expected) (-> Tag (Parser Any)) - (function (_ docs) - (case docs + (function (_ documents) + (case documents #.Nil (exception.throw ..empty_input []) @@ -65,13 +65,13 @@ (#/.Node actual _attributes _children) (if (name\= expected actual) - (#try.Success [docs []]) + (#try.Success [documents []]) (exception.throw ..wrong_tag [expected actual])))))) (def: #export tag (Parser Tag) - (function (_ docs) - (case docs + (function (_ documents) + (case documents #.Nil (exception.throw ..empty_input []) @@ -81,12 +81,12 @@ (exception.throw ..unexpected_input []) (#/.Node tag _attributes _children) - (#try.Success [docs tag]))))) + (#try.Success [documents tag]))))) (def: #export (attribute name) (-> Attribute (Parser Text)) - (function (_ docs) - (case docs + (function (_ documents) + (case documents #.Nil (exception.throw ..empty_input []) @@ -101,11 +101,11 @@ (exception.throw ..unknown_attribute [name (dictionary.keys attributes)]) (#.Some value) - (#try.Success [docs value])))))) + (#try.Success [documents value])))))) -(def: (run' parser docs) +(def: #export (run parser documents) (All [a] (-> (Parser a) (List XML) (Try a))) - (case (//.run parser docs) + (case (//.run parser documents) (#try.Success [remaining output]) (if (list.empty? remaining) (#try.Success output) @@ -116,8 +116,8 @@ (def: #export (children parser) (All [a] (-> (Parser a) (Parser a))) - (function (_ docs) - (case docs + (function (_ documents) + (case documents #.Nil (exception.throw ..empty_input []) @@ -128,23 +128,19 @@ (#/.Node _tag _attributes children) (do try.monad - [output (run' parser children)] + [output (..run parser children)] (wrap [tail output])))))) (def: #export ignore (Parser Any) - (function (_ docs) - (case docs + (function (_ documents) + (case documents #.Nil (exception.throw ..empty_input []) (#.Cons head tail) (#try.Success [tail []])))) -(def: #export (run parser document) - (All [a] (-> (Parser a) XML (Try a))) - (..run' parser (list document))) - (exception: #export nowhere) (def: #export (somewhere parser) diff --git a/stdlib/source/lux/debug.lux b/stdlib/source/lux/debug.lux index 088504f2d..b60d62c11 100644 --- a/stdlib/source/lux/debug.lux +++ b/stdlib/source/lux/debug.lux @@ -22,14 +22,16 @@ [collection ["." array] ["." list ("#\." functor)]]] - [time - [instant (#+ Instant)] - [duration (#+ Duration)] - [date (#+ Date)]] + ["." meta + ["." location]] [macro ["." template] ["." syntax (#+ syntax:)] - ["." code]]]) + ["." code]] + [time + [instant (#+ Instant)] + [duration (#+ Duration)] + [date (#+ Date)]]]) (with_expansions [<jvm> (as_is (import: java/lang/String) @@ -161,7 +163,8 @@ (exception.report ["Type" (%.type type)])) -(type: Representation (-> Any Text)) +(type: Representation + (-> Any Text)) (def: primitive_representation (Parser Representation) @@ -304,3 +307,14 @@ "Useful for debugging.")} (-> Text Any) ("lux io log" message)) + +(exception: #export (type_hole {location Location} {type Type}) + (exception.report + ["Location" (location.format location)] + ["Type" (%.type type)])) + +(syntax: #export (:hole) + (do meta.monad + [location meta.location + expectedT meta.expected_type] + (meta.fail (exception.construct ..type_hole [location expectedT])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux index 1c45a95b5..38f5125ea 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux @@ -304,27 +304,19 @@ pattern_matching!) (_.throw (_.string ////synthesis/case.pattern_matching_error)))))) -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (do ///////phase.monad - [stack_init (expression archive valueS) - pattern_matching! (pattern_matching statement expression archive pathP) - #let [closure (<| (_.closure (list)) - ($_ _.then - (_.declare @temp) - (_.define @cursor (_.array (list stack_init))) - (_.define @savepoint (_.array (list))) - pattern_matching! - ))]] - (wrap (_.apply/* closure (list))))) - (def: #export (case! statement expression archive [valueS pathP]) (Generator! [Synthesis Path]) (do ///////phase.monad [stack_init (expression archive valueS) - path! (pattern_matching statement expression archive pathP)] + pattern_matching! (pattern_matching statement expression archive pathP)] (wrap ($_ _.then (_.declare @temp) (_.define @cursor (_.array (list stack_init))) (_.define @savepoint (_.array (list))) - path!)))) + pattern_matching!)))) + +(def: #export (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (do ///////phase.monad + [pattern_matching! (..case! statement expression archive [valueS pathP])] + (wrap (_.apply/* (_.closure (list) pattern_matching!) (list))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux index 93300a02d..9ab6f4056 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux @@ -1,9 +1,13 @@ (.module: [lux #* [abstract - [monad (#+ do)]]] + [monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [target + ["_" python]]] ["." / #_ - [runtime (#+ Phase)] + [runtime (#+ Phase Phase!)] ["#." primitive] ["#." structure] ["#." reference] @@ -21,7 +25,45 @@ [reference (#+) [variable (#+)]]]]]]]) -(def: #export (generate archive synthesis) +(exception: #export cannot-recur-as-an-expression) + +(def: (statement expression archive synthesis) + Phase! + (case synthesis + (^template [<tag>] + [(^ (<tag> value)) + (//////phase\map _.return (expression archive synthesis))]) + ([////synthesis.bit] + [////synthesis.i64] + [////synthesis.f64] + [////synthesis.text] + [////synthesis.variant] + [////synthesis.tuple] + [#////synthesis.Reference] + [////synthesis.branch/get] + [////synthesis.function/apply] + [#////synthesis.Extension]) + + (^ (////synthesis.branch/case case)) + (/case.case! statement expression archive case) + + (^ (////synthesis.branch/let let)) + (/case.let! statement expression archive let) + + (^ (////synthesis.branch/if if)) + (/case.if! statement expression archive if) + + (^ (////synthesis.loop/scope scope)) + (/loop.scope! statement expression archive scope) + + (^ (////synthesis.loop/recur updates)) + (/loop.recur! statement expression archive updates) + + (^ (////synthesis.function/abstraction abstraction)) + (//////phase\map _.return (/function.function statement expression archive abstraction)) + )) + +(def: #export (expression archive synthesis) Phase (case synthesis (^template [<tag> <generator>] @@ -33,37 +75,41 @@ [////synthesis.text /primitive.text]) (^ (////synthesis.variant variantS)) - (/structure.variant generate archive variantS) + (/structure.variant expression archive variantS) (^ (////synthesis.tuple members)) - (/structure.tuple generate archive members) + (/structure.tuple expression archive members) (#////synthesis.Reference value) (//reference.reference /reference.system archive value) (^ (////synthesis.branch/case case)) - (/case.case generate archive case) + (/case.case ..statement expression archive case) (^ (////synthesis.branch/let let)) - (/case.let generate archive let) + (/case.let expression archive let) (^ (////synthesis.branch/if if)) - (/case.if generate archive if) + (/case.if expression archive if) (^ (////synthesis.branch/get get)) - (/case.get generate archive get) + (/case.get expression archive get) (^ (////synthesis.loop/scope scope)) - (/loop.scope generate archive scope) + (/loop.scope ..statement expression archive scope) (^ (////synthesis.loop/recur updates)) - (/loop.recur generate archive updates) + (//////phase.throw ..cannot-recur-as-an-expression []) (^ (////synthesis.function/abstraction abstraction)) - (/function.function generate archive abstraction) + (/function.function ..statement expression archive abstraction) (^ (////synthesis.function/apply application)) - (/function.apply generate archive application) + (/function.apply expression archive application) (#////synthesis.Extension extension) - (///extension.apply archive generate extension))) + (///extension.apply archive expression extension))) + +(def: #export generate + Phase + ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux index dfc327985..e3be48bc6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux @@ -17,7 +17,7 @@ [target ["_" python (#+ Expression SVar Statement)]]] ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] + ["#." runtime (#+ Operation Phase Generator Phase! Generator!)] ["#." reference] ["#." primitive] ["/#" // #_ @@ -43,28 +43,47 @@ (-> Register SVar) (|>> (///reference.foreign //reference.system) :assume)) -(def: #export (let generate archive [valueS register bodyS]) +(def: #export (let expression archive [valueS register bodyS]) (Generator [Synthesis Register Synthesis]) (do ///////phase.monad - [valueO (generate archive valueS) - bodyO (generate archive bodyS)] + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] ## TODO: Find some way to do 'let' without paying the price of the closure. (wrap (_.apply/* (_.lambda (list (..register register)) bodyO) (list valueO))))) -(def: #export (if generate archive [testS thenS elseS]) +(def: #export (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (wrap ($_ _.then + (_.set (list (..register register)) valueO) + bodyO)))) + +(def: #export (if expression archive [testS thenS elseS]) (Generator [Synthesis Synthesis Synthesis]) (do ///////phase.monad - [testO (generate archive testS) - thenO (generate archive thenS) - elseO (generate archive elseS)] + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] (wrap (_.? testO thenO elseO)))) -(def: #export (get generate archive [pathP valueS]) +(def: #export (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [test! (expression archive testS) + then! (statement expression archive thenS) + else! (statement expression archive elseS)] + (wrap (_.if test! + then! + else!)))) + +(def: #export (get expression archive [pathP valueS]) (Generator [(List Member) Synthesis]) (do ///////phase.monad - [valueO (generate archive valueS)] + [valueO (expression archive valueS)] (wrap (list\fold (function (_ side source) (.let [method (.case side (^template [<side> <accessor>] @@ -139,12 +158,12 @@ ..restore! post!))) -(def: (pattern_matching' generate archive) - (-> Phase Archive Path (Operation (Statement Any))) +(def: (pattern_matching' statement expression archive) + (-> Phase! Phase Archive Path (Operation (Statement Any))) (function (recur pathP) (.case pathP (^ (/////synthesis.path/then bodyS)) - (///////phase\map _.return (generate archive bodyS)) + (statement expression archive bodyS) #/////synthesis.Pop (///////phase\wrap ..pop!) @@ -239,16 +258,16 @@ ([/////synthesis.path/seq _.then] [/////synthesis.path/alt ..alternation])))) -(def: (pattern_matching generate archive pathP) - (-> Phase Archive Path (Operation (Statement Any))) +(def: (pattern_matching statement expression archive pathP) + (-> Phase! Phase Archive Path (Operation (Statement Any))) (do ///////phase.monad - [pattern_matching! (pattern_matching' generate archive pathP)] + [pattern_matching! (pattern_matching' statement expression archive pathP)] (wrap ($_ _.then (_.while (_.bool true) pattern_matching!) (_.raise (_.Exception/1 (_.string case.pattern_matching_error))))))) -(def: (gensym prefix) +(def: #export (gensym prefix) (-> Text (Operation SVar)) (///////phase\map (|>> %.nat (format prefix) _.var) /////generation.next)) @@ -265,20 +284,26 @@ (#///////variable.Foreign register) (..capture register)))))) -(def: #export (case generate archive [valueS pathP]) - (Generator [Synthesis Path]) +(def: #export (case! statement expression archive [valueS pathP]) + (Generator! [Synthesis Path]) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching statement expression archive pathP)] + (wrap ($_ _.then + (_.set (list @cursor) (_.list (list stack_init))) + (_.set (list @savepoint) (_.list (list))) + pattern_matching! + )))) + +(def: #export (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) (do ///////phase.monad - [initG (generate archive valueS) - pattern_matching! (pattern_matching generate archive pathP) + [pattern_matching! (case! statement expression archive [valueS pathP]) @case (..gensym "case") - @init (..gensym "init") - #let [@dependencies+ (..dependencies pathP) - directive (_.def @case (list& @init @dependencies+) - ($_ _.then - (_.set (list @cursor) (_.list (list @init))) - (_.set (list @savepoint) (_.list (list))) - pattern_matching! - ))] + #let [@dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) + pathP)) + directive (_.def @case @dependencies+ + pattern_matching!)] _ (/////generation.execute! directive) _ (/////generation.save! (_.code @case) directive)] - (wrap (_.apply/* @case (list& initG @dependencies+))))) + (wrap (_.apply/* @case @dependencies+)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux index 8c97fec96..23619eafc 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux @@ -11,9 +11,10 @@ [target ["_" python (#+ SVar Expression Statement)]]] ["." // #_ - [runtime (#+ Operation Phase Generator)] + [runtime (#+ Operation Phase Generator Phase! Generator!)] ["#." reference] ["#." case] + ["#." loop] ["/#" // #_ ["#." reference] ["//#" /// #_ @@ -26,11 +27,11 @@ [reference [variable (#+ Register Variable)]]]]]]) -(def: #export (apply generate archive [functionS argsS+]) +(def: #export (apply expression archive [functionS argsS+]) (Generator (Application Synthesis)) (do {! ///////phase.monad} - [functionO (generate archive functionS) - argsO+ (monad.map ! (generate archive) argsS+)] + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] (wrap (_.apply/* functionO argsO+)))) (def: #export capture @@ -62,16 +63,18 @@ (def: input (|>> inc //case.register)) -(def: #export (function generate archive [environment arity bodyS]) - (Generator (Abstraction Synthesis)) +(def: #export (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) (do {! ///////phase.monad} - [[function_name bodyO] (/////generation.with_new_context archive + [@expected_exception (//case.gensym "expected_exception") + @actual_exception (//case.gensym "actual_exception") + [function_name body!] (/////generation.with_new_context archive (do ! [function_name (\ ! map ///reference.artifact (/////generation.context archive))] - (/////generation.with_anchor (_.var function_name) - (generate archive bodyS)))) - environment (monad.map ! (generate archive) environment) + (/////generation.with_anchor [1 @expected_exception] + (statement expression archive bodyS)))) + environment (monad.map ! (expression archive) environment) #let [function_name (///reference.artifact function_name) @curried (_.var "curried") arityO (|> arity .int _.int) @@ -91,9 +94,9 @@ ($_ _.then (_.set (list @num_args) (_.len/1 @curried)) (_.cond (list [(|> @num_args (_.= arityO)) - ($_ _.then - initialize! - (_.return bodyO))] + (<| (_.then initialize!) + (//loop.set_scope @expected_exception @actual_exception) + body!)] [(|> @num_args (_.> arityO)) (let [arity_inputs (_.slice (_.int +0) arityO @curried) extra_inputs (_.slice arityO @num_args @curried)] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux index 7e92ddb74..563e8ee61 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux @@ -7,15 +7,15 @@ [text ["%" format (#+ format)]] [collection - ["." list ("#\." functor)] + ["." list ("#\." functor fold)] ["." set]]] [math [number ["n" nat]]] [target - ["_" python (#+ Expression SVar)]]] + ["_" python (#+ Expression SVar Statement)]]] ["." // #_ - [runtime (#+ Operation Phase Generator)] + [runtime (#+ Operation Phase Generator Phase! Generator!)] ["#." case] ["//#" /// #_ [synthesis @@ -26,44 +26,89 @@ ["//#" /// #_ ["#." phase] [reference - ["#." variable]]]]]]) + ["#." variable (#+ Register)]]]]]]) (def: loop_name (-> Nat SVar) (|>> %.nat (format "loop") _.var)) -(def: #export (scope generate archive [start initsS+ bodyS]) - (Generator (Scope Synthesis)) +(def: (setup offset bindings body) + (-> Register (List (Expression Any)) (Statement Any) (Statement Any)) + (|> bindings + list.enumeration + (list\map (function (_ [register value]) + (_.set (list (//case.register (n.+ offset register))) + value))) + list.reverse + (list\fold _.then body))) + +(def: #export (set_scope @expected_exception @actual_exception body!) + (-> SVar SVar (Statement Any) (Statement Any)) + (let [exception_class (_.var "Exception")] + ($_ _.then + (_.set (list @expected_exception) (_.apply/* exception_class (list (_.string "")))) + (_.while (_.bool true) + (_.try body! + (list {#_.classes (list exception_class) + #_.exception @actual_exception + #_.handler (_.if (_.is @expected_exception @actual_exception) + _.continue + (_.raise @actual_exception))})))))) + +(def: #export (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) (case initsS+ ## function/false/non-independent loop #.Nil - (generate archive bodyS) + (statement expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [initsO+ (monad.map ! (expression archive) initsS+) + @expected_exception (//case.gensym "expected_exception") + @actual_exception (//case.gensym "actual_exception") + body! (/////generation.with_anchor [start @expected_exception] + (statement expression archive bodyS))] + (wrap (<| (..setup start initsO+) + (set_scope @expected_exception @actual_exception) + body!))))) + +(def: #export (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) ## true loop _ (do {! ///////phase.monad} [@loop (\ ! map ..loop_name /////generation.next) - initsO+ (monad.map ! (generate archive) initsS+) - bodyO (/////generation.with_anchor @loop - (generate archive bodyS)) + @expected_exception (//case.gensym "expected_exception") + @actual_exception (//case.gensym "actual_exception") + initsO+ (monad.map ! (expression archive) initsS+) + body! (/////generation.with_anchor [start @expected_exception] + (statement expression archive bodyS)) #let [locals (|> initsS+ list.enumeration (list\map (|>> product.left (n.+ start) //case.register))) + actual_loop (<| (_.def @loop locals) + (set_scope @expected_exception @actual_exception) + body!) [directive instantiation] (case (|> (synthesis.path/then bodyS) //case.dependencies (set.from_list _.hash) (set.difference (set.from_list _.hash locals)) set.to_list) #.Nil - [(_.def @loop locals - (_.return bodyO)) + [actual_loop (_.apply/* @loop initsO+)] foreigns [(_.def @loop foreigns ($_ _.then - (_.def @loop locals - (_.return bodyO)) + actual_loop (_.return @loop) )) (_.apply/* (_.apply/* @loop @@ -73,9 +118,17 @@ _ (/////generation.save! (_.code @loop) directive)] (wrap instantiation)))) -(def: #export (recur generate archive argsS+) - (Generator (List Synthesis)) +(def: #export (recur! statement expression archive argsS+) + (Generator! (List Synthesis)) (do {! ///////phase.monad} - [@scope /////generation.anchor - argsO+ (monad.map ! (generate archive) argsS+)] - (wrap (_.apply/* @scope argsO+)))) + [[offset @exception] /////generation.anchor + @temp (//case.gensym "lux_recur_values") + argsO+ (monad.map ! (expression archive) argsS+) + #let [re_binds (|> argsO+ + list.enumeration + (list\map (function (_ [idx _]) + (_.nth (_.int (.int idx)) @temp))))]] + (wrap ($_ _.then + (_.set (list @temp) (_.list argsO+)) + (..setup offset re_binds + (_.raise @exception)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux index 5ed9e7d2a..fc2e95789 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux @@ -27,17 +27,19 @@ ["#." reference] ["//#" /// #_ ["$" version] - ["#." synthesis] + ["#." synthesis (#+ Synthesis)] ["#." generation] ["//#" /// (#+ Output) ["#." phase] + [reference + [variable (#+ Register)]] [meta [archive (#+ Archive) ["." artifact (#+ Registry)]]]]]]) (template [<name> <base>] [(type: #export <name> - (<base> SVar (Expression Any) (Statement Any)))] + (<base> [Register SVar] (Expression Any) (Statement Any)))] [Operation /////generation.Operation] [Phase /////generation.Phase] @@ -45,12 +47,21 @@ [Bundle /////generation.Bundle] ) +(type: #export Phase! + (-> Phase Archive Synthesis (Operation (Statement Any)))) + +(type: #export (Generator! i) + (-> Phase! Phase Archive i (Operation (Statement Any)))) + (type: #export (Generator i) (-> Phase Archive i (Operation (Expression Any)))) -(def: prefix Text "LuxRuntime") +(def: prefix + "LuxRuntime") -(def: #export unit (_.string /////synthesis.unit)) +(def: #export + unit + (_.string /////synthesis.unit)) (def: (flag value) (-> Bit Literal) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index bcc71cd12..9372cc4e0 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -435,14 +435,3 @@ (~ (get@ #expression exemplar))} {(~ extraction) (:assume [])})))))) - -(exception: #export (hole_type {location Location} {type Type}) - (exception.report - ["Location" (location.format location)] - ["Type" (..format type)])) - -(syntax: #export (:hole) - (do meta.monad - [location meta.location - expectedT meta.expected_type] - (meta.fail (exception.construct ..hole_type [location expectedT])))) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index 2c7c00506..15534b996 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -7,7 +7,7 @@ [control ["." exception (#+ exception:)] ["<>" parser ("#\." monad) - ["<c>" code (#+ Parser)]]] + ["<.>" code (#+ Parser)]]] [data ["." name ("#\." codec)] ["." text ("#\." equivalence monoid)] @@ -170,8 +170,8 @@ (def: cast (Parser [(Maybe Text) Code]) - (<>.either (<>.and (<>.maybe <c>.local_identifier) <c>.any) - (<>.and (<>\wrap #.None) <c>.any))) + (<>.either (<>.and (<>.maybe <code>.local_identifier) <code>.any) + (<>.and (<>\wrap #.None) <code>.any))) (template [<name> <from> <to>] [(syntax: #export (<name> {[frame value] ..cast}) @@ -194,13 +194,13 @@ (def: representation_definition_name (-> Text Text) (|>> ($_ text\compose - (name\encode (name_of #Representation)) + (name\encode (name_of #..Representation)) " "))) (def: declaration (Parser [Text (List Text)]) - (<>.either (<c>.form (<>.and <c>.local_identifier (<>.some <c>.local_identifier))) - (<>.and <c>.local_identifier (\ <>.monad wrap (list))))) + (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier))) + (<>.and <code>.local_identifier (\ <>.monad wrap (list))))) ## TODO: Make sure the generated code always gets optimized away. ## (This applies to uses of ":abstraction" and ":representation") @@ -209,7 +209,7 @@ {[name type_vars] declaration} representation_type {annotations (<>.default |annotations|.empty |annotations|.parser)} - {primitives (<>.some <c>.any)}) + {primitives (<>.some <code>.any)}) (do meta.monad [current_module meta.current_module_name #let [type_varsC (list\map code.local_identifier type_vars) @@ -230,14 +230,39 @@ primitives (list (` ((~! ..pop!))))))))) -(syntax: #export (:transmutation value) - (wrap (list (` (..:abstraction (..:representation (~ value))))))) - -(syntax: #export (^:representation {name (<c>.form <c>.local_identifier)} +(type: (Selection a) + (#Specific Code a) + (#Current a)) + +(def: (selection parser) + (All [a] (-> (Parser a) (Parser (Selection a)))) + (<>.or (<>.and <code>.any parser) + parser)) + +(syntax: #export (:transmutation {selection (..selection <code>.any)}) + (case selection + (#Specific specific value) + (wrap (list (` (..:abstraction (~ specific) + (..:representation (~ specific) + (~ value)))))) + + (#Current value) + (wrap (list (` (..:abstraction (..:representation (~ value)))))))) + +(syntax: #export (^:representation {selection (<code>.form (..selection <code>.local_identifier))} body - {branches (<>.some <c>.any)}) - (let [g!var (code.local_identifier name)] - (wrap (list& g!var - (` (.let [(~ g!var) (..:representation (~ g!var))] - (~ body))) - branches)))) + {branches (<>.some <code>.any)}) + (case selection + (#Specific specific name) + (let [g!var (code.local_identifier name)] + (wrap (list& g!var + (` (.let [(~ g!var) (..:representation (~ specific) (~ g!var))] + (~ body))) + branches))) + + (#Current name) + (let [g!var (code.local_identifier name)] + (wrap (list& g!var + (` (.let [(~ g!var) (..:representation (~ g!var))] + (~ body))) + branches))))) diff --git a/stdlib/source/program/aedifex/artifact/build.lux b/stdlib/source/program/aedifex/artifact/snapshot/build.lux index d9a8b729e..d9a8b729e 100644 --- a/stdlib/source/program/aedifex/artifact/build.lux +++ b/stdlib/source/program/aedifex/artifact/snapshot/build.lux diff --git a/stdlib/source/program/aedifex/artifact/snapshot/stamp.lux b/stdlib/source/program/aedifex/artifact/snapshot/stamp.lux new file mode 100644 index 000000000..c1efcc8ee --- /dev/null +++ b/stdlib/source/program/aedifex/artifact/snapshot/stamp.lux @@ -0,0 +1,55 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." product] + [format + [xml (#+ XML)]]]] + ["." // #_ + ["#." time (#+ Time)] + ["#." build (#+ Build)]]) + +(type: #export Stamp + {#time Time + #build Build}) + +(def: #export equivalence + (Equivalence Stamp) + ($_ product.equivalence + //time.equivalence + //build.equivalence + )) + +(def: time_format + (-> Time XML) + (|>> //time.format + #xml.Text + list + (#xml.Node ..tag xml.attributes))) + +(def: #export (format (^slots [#time #build])) + (-> Stamp (List XML)) + (list (..time_format time) + (//build.format build))) + +(def: <timestamp> + xml.Tag + ["" "timestamp"]) + +## (exception: #export (mismatch {expected Instant} {actual Instant}) +## (exception.report +## ["Expected" (%.instant expected)] +## ["Actual" (%.instant actual)])) + +(def: time_parser + (Parser Time) + (do <>.monad + [_ (<xml>.node <timestamp>)] + (<text>.embed //time.parser + (<xml>.children <xml>.text)))) + +(def: #export parser + (Parser Stamp) + (<>.and (<xml>.somewhere ..time_parser) + (<xml>.somewhere //build.parser))) diff --git a/stdlib/source/program/aedifex/artifact/snapshot/time.lux b/stdlib/source/program/aedifex/artifact/snapshot/time.lux new file mode 100644 index 000000000..ea9bf3047 --- /dev/null +++ b/stdlib/source/program/aedifex/artifact/snapshot/time.lux @@ -0,0 +1,45 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" text] + ["<.>" xml (#+ Parser)]]] + [data + [text + ["%" format]] + [format + ["." xml (#+ XML)]]] + [time + ["." instant (#+ Instant)]]] + ["." /// #_ + [time + ["#." date] + ["#." time]]]) + +(type: #export Time + Instant) + +(def: #export equivalence + (Equivalence Time) + instant.equivalence) + +(def: separator + ".") + +(def: #export (format value) + (%.Format Time) + (%.format (///date.format (instant.date value)) + ..separator + (///time.format (instant.time value)))) + +(def: #export parser + (<text>.Parser Time) + (do <>.monad + [date ///date.parser + _ (<text>.this ..separator) + time ///time.parser] + (wrap (instant.from_date_time date time)))) diff --git a/stdlib/source/program/aedifex/artifact/time_stamp.lux b/stdlib/source/program/aedifex/artifact/time_stamp.lux deleted file mode 100644 index 0eab45a14..000000000 --- a/stdlib/source/program/aedifex/artifact/time_stamp.lux +++ /dev/null @@ -1,35 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["<>" parser - ["<.>" text (#+ Parser)]]] - [data - [text - ["%" format]]] - [time - ["." instant (#+ Instant)]]] - ["." / #_ - ["#." date] - ["#." time]]) - -(type: #export Time_Stamp - Instant) - -(def: #export separator - ".") - -(def: #export (format value) - (%.Format Time_Stamp) - (%.format (/date.format (instant.date value)) - ..separator - (/time.format (instant.time value)))) - -(def: #export parser - (Parser Time_Stamp) - (do <>.monad - [date /date.parser - _ (<text>.this ..separator) - time /time.parser] - (wrap (instant.from_date_time date time)))) diff --git a/stdlib/source/spec/lux/world/console.lux b/stdlib/source/spec/lux/world/console.lux index f875cd07e..5bfcf1ff8 100644 --- a/stdlib/source/spec/lux/world/console.lux +++ b/stdlib/source/spec/lux/world/console.lux @@ -10,6 +10,9 @@ ["!" capability]] [concurrency ["." promise (#+ Promise)]]] + [data + ["." text + ["%" format (#+ format)]]] [math ["." random]]] {1 @@ -22,19 +25,12 @@ [message (random.ascii/alpha 10)] (wrap (do promise.monad [console (promise.future console) + ?write (!.use (\ console write) [(format message text.new_line)]) ?read (!.use (\ console read) []) ?read_line (!.use (\ console read_line) []) - ?write (!.use (\ console write) [message]) ?close/good (!.use (\ console close) []) ?close/bad (!.use (\ console close) [])] ($_ _.and' - (_.cover' [/.Can_Read] - (case [?read ?read_line] - [(#try.Success _) (#try.Success _)] - true - - _ - false)) (_.cover' [/.Can_Write] (case ?write (#try.Success _) @@ -42,6 +38,13 @@ _ false)) + (_.cover' [/.Can_Read] + (case [?read ?read_line] + [(#try.Success _) (#try.Success _)] + true + + _ + false)) (_.cover' [/.Can_Close] (case [?close/good ?close/bad] [(#try.Success _) (#try.Failure _)] diff --git a/stdlib/source/test/aedifex/artifact/build.lux b/stdlib/source/test/aedifex/artifact/snapshot/build.lux index d0920b44c..e3fdcab62 100644 --- a/stdlib/source/test/aedifex/artifact/build.lux +++ b/stdlib/source/test/aedifex/artifact/snapshot/build.lux @@ -11,23 +11,28 @@ [parser ["<.>" xml]]] [math - ["." random]]] + ["." random (#+ Random)]]] {#program ["." /]}) +(def: #export random + (Random /.Build) + random.nat) + (def: #export test Test (<| (_.covering /._) (_.for [/.Build] ($_ _.and (_.for [/.equivalence] - ($equivalence.spec /.equivalence random.nat)) + ($equivalence.spec /.equivalence ..random)) (do random.monad - [expected random.nat] + [expected ..random] (_.cover [/.format /.parser] (|> expected /.format + list (<xml>.run /.parser) (try\map (\ /.equivalence = expected)) (try.default false)))) diff --git a/stdlib/source/test/aedifex/artifact/snapshot/stamp.lux b/stdlib/source/test/aedifex/artifact/snapshot/stamp.lux new file mode 100644 index 000000000..aab722cad --- /dev/null +++ b/stdlib/source/test/aedifex/artifact/snapshot/stamp.lux @@ -0,0 +1,48 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] + [control + ["." try ("#\." functor)] + [parser + ["<.>" xml]]] + [math + ["." random (#+ Random)]] + [time + ["." instant]]] + {#program + ["." /]} + ["$." // #_ + ["#." time] + ["#." build]]) + +(def: #export random + (Random /.Stamp) + ($_ random.and + $//time.random + $//build.random + )) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Stamp]) + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + + (do random.monad + [expected ..random] + ($_ _.and + (_.cover [/.format /.parser] + (|> expected + /.format + (<xml>.run' /.parser) + (try\map (\ instant.equivalence = expected)) + (try.default false))) + )) + ))) diff --git a/stdlib/source/test/aedifex/artifact/snapshot/time.lux b/stdlib/source/test/aedifex/artifact/snapshot/time.lux new file mode 100644 index 000000000..567c70ce4 --- /dev/null +++ b/stdlib/source/test/aedifex/artifact/snapshot/time.lux @@ -0,0 +1,42 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] + [control + ["." try ("#\." functor)] + [parser + ["<.>" text]]] + [math + ["." random (#+ Random)]] + [time + ["." instant]]] + {#program + ["." /]}) + +(def: #export random + (Random /.Time) + random.instant) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Time]) + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + + (do random.monad + [expected ..random] + ($_ _.and + (_.cover [/.format /.parser] + (|> expected + /.format + (<text>.run /.parser) + (try\map (\ instant.equivalence = expected)) + (try.default false))) + )) + ))) diff --git a/stdlib/source/test/aedifex/artifact/time_stamp.lux b/stdlib/source/test/aedifex/artifact/time_stamp.lux deleted file mode 100644 index 7dea57392..000000000 --- a/stdlib/source/test/aedifex/artifact/time_stamp.lux +++ /dev/null @@ -1,33 +0,0 @@ -(.module: - [lux #* - ["_" test (#+ Test)] - [abstract - [monad (#+ do)]] - [control - ["." try ("#\." functor)] - [parser - ["<.>" text]]] - [math - ["." random (#+ Random)] - [number - ["n" nat] - ["i" int]]] - [time - ["." instant]]] - {#program - ["." /]}) - -(def: #export test - Test - (<| (_.covering /._) - (_.for [/.Time_Stamp]) - ($_ _.and - (do random.monad - [expected random.instant] - (_.cover [/.format /.parser] - (|> expected - /.format - (<text>.run /.parser) - (try\map (\ instant.equivalence = expected)) - (try.default false)))) - ))) diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux index d983ab382..487e4c48c 100644 --- a/stdlib/source/test/lux/control/concurrency/actor.lux +++ b/stdlib/source/test/lux/control/concurrency/actor.lux @@ -32,9 +32,6 @@ ((on_mail message state self) (message state self)) - ((on_stop cause state) - (promise\wrap [])) - (message: (count! {increment Nat} state self Nat) (let [state' (n.+ increment state)] (promise\wrap (#try.Success [state' state'])))) @@ -90,9 +87,16 @@ [actor (/.spawn! (: (/.Behavior Any Any) {#/.on_init (|>>) #/.on_mail (function (_ message state self) - (message state self)) - #/.on_stop (function (_ cause state) - (promise.future (write cause)))}) + (do {! promise.monad} + [outcome (message state self)] + (case outcome + (#try.Failure cause) + (do ! + [_ (promise.future (write cause))] + (wrap outcome)) + + (#try.Success _) + (wrap outcome))))}) [])] (/.poison! actor))) _ (promise.wait 100) @@ -172,11 +176,7 @@ [anonymous (/.actor {Nat initial_state} ((on_mail message state self) - (message (inc state) self)) - - ((on_stop cause state) - (promise\wrap (exec (%.nat state) - [])))) + (message (inc state) self))) sent/inc? (/.mail! inc! anonymous) sent/dec? (/.mail! dec! anonymous) poisoned? (/.poison! anonymous) diff --git a/stdlib/source/test/lux/control/parser/xml.lux b/stdlib/source/test/lux/control/parser/xml.lux index a9f71af71..c2d0ac4e2 100644 --- a/stdlib/source/test/lux/control/parser/xml.lux +++ b/stdlib/source/test/lux/control/parser/xml.lux @@ -39,7 +39,7 @@ [expected (random.ascii/alpha 1)] (_.cover [<exception>] (`` (and (~~ (template [<parser> <input>] - [(|> (/.run <parser> <input>) + [(|> (/.run <parser> (list <input>)) (!expect (^multi (#try.Failure error) (exception.match? <exception> error))))] @@ -61,7 +61,7 @@ (do {! random.monad} [expected (random.ascii/alpha 1)] (_.cover [/.run /.text] - (|> (/.run /.text (#xml.Text expected)) + (|> (/.run /.text (list (#xml.Text expected))) (!expect (^multi (#try.Success actual) (text\= expected actual)))))) (!failure /.unconsumed_inputs @@ -70,7 +70,7 @@ (do {! random.monad} [expected (random.ascii/alpha 1)] (_.cover [/.ignore] - (|> (/.run /.ignore (#xml.Text expected)) + (|> (/.run /.ignore (list (#xml.Text expected))) (!expect (#try.Success []))))) (do {! random.monad} [expected ..random_tag] @@ -79,7 +79,7 @@ [actual /.tag _ /.ignore] (wrap (name\= expected actual))) - (#xml.Node expected (dictionary.new name.hash) (list))) + (list (#xml.Node expected (dictionary.new name.hash) (list)))) (!expect (#try.Success #1))))) (do {! random.monad} [expected ..random_tag] @@ -87,7 +87,7 @@ (|> (/.run (do //.monad [_ (/.node expected)] /.ignore) - (#xml.Node expected (dictionary.new name.hash) (list))) + (list (#xml.Node expected (dictionary.new name.hash) (list)))) (!expect (#try.Success []))))) (!failure /.wrong_tag [[(/.node ["" expected]) @@ -101,10 +101,10 @@ [_ (/.node expected_tag) _ (/.attribute expected_attribute)] /.ignore) - (#xml.Node expected_tag - (|> (dictionary.new name.hash) - (dictionary.put expected_attribute expected_value)) - (list))) + (list (#xml.Node expected_tag + (|> (dictionary.new name.hash) + (dictionary.put expected_attribute expected_value)) + (list)))) (!expect (#try.Success []))))) (!failure /.unknown_attribute [[(do //.monad @@ -123,11 +123,11 @@ (do ! [_ (/.node expected)] /.ignore))) - (#xml.Node expected - (dictionary.new name.hash) - (list (#xml.Node expected - (dictionary.new name.hash) - (list))))) + (list (#xml.Node expected + (dictionary.new name.hash) + (list (#xml.Node expected + (dictionary.new name.hash) + (list)))))) (!expect (#try.Success []))))) (!failure /.empty_input [[(do //.monad @@ -195,15 +195,15 @@ ($_ _.and (_.cover [/.somewhere] (|> (/.run parser - (node parent - (list.concat (list (list.repeat repetitions (node wrong (list))) - (list (node right (list))) - (list.repeat repetitions (node wrong (list))))))) + (list (node parent + (list.concat (list (list.repeat repetitions (node wrong (list))) + (list (node right (list))) + (list.repeat repetitions (node wrong (list)))))))) (!expect (#try.Success [])))) (_.cover [/.nowhere] (|> (/.run parser - (node parent - (list.repeat repetitions (node wrong (list))))) + (list (node parent + (list.repeat repetitions (node wrong (list)))))) (!expect (^multi (#try.Failure error) (exception.match? /.nowhere error))))) )) diff --git a/stdlib/source/test/lux/macro/template.lux b/stdlib/source/test/lux/macro/template.lux index 53d7d114e..b129aaaef 100644 --- a/stdlib/source/test/lux/macro/template.lux +++ b/stdlib/source/test/lux/macro/template.lux @@ -3,9 +3,15 @@ ["_" test (#+ Test)] [abstract [monad (#+ do)]] + [control + ["." try] + ["." exception]] [data [collection ["." list]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] [math ["." random (#+ Random)] [number @@ -19,6 +25,15 @@ (-> Nat Nat) (|>> !pow/2))) +(syntax: (macro_error macro) + (function (_ compiler) + (case ((macro.expand macro) compiler) + (#try.Failure error) + (#try.Success [compiler (list (code.text error))]) + + (#try.Success _) + (#try.Failure "OOPS!")))) + (def: #export test Test (<| (_.covering /._) @@ -97,5 +112,15 @@ can_refer! can_shadow!))) )))) + (_.cover [/.irregular_arguments] + (/.with [(arity/3 <0> <1> <2>) + ""] + (exception.match? /.irregular_arguments + (macro_error (arity/3 "a" "b"))))) + (_.cover [/.cannot_shadow_definition] + (exception.match? /.cannot_shadow_definition + (macro_error (/.with [(macro_error <0> <1> <2>) + ""] + "")))) ))) )) diff --git a/stdlib/source/test/lux/type.lux b/stdlib/source/test/lux/type.lux index 168ed29d1..70b13a382 100644 --- a/stdlib/source/test/lux/type.lux +++ b/stdlib/source/test/lux/type.lux @@ -17,6 +17,7 @@ {1 ["." / ("#\." equivalence)]} ["." / #_ + ["#." abstract] ["#." check] ["#." dynamic] ["#." implicit] @@ -164,6 +165,7 @@ {(Maybe a) example} (List a))))) + /abstract.test /check.test /dynamic.test /implicit.test diff --git a/stdlib/source/test/lux/type/abstract.lux b/stdlib/source/test/lux/type/abstract.lux new file mode 100644 index 000000000..30ad27687 --- /dev/null +++ b/stdlib/source/test/lux/type/abstract.lux @@ -0,0 +1,110 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." exception]] + [data + ["." text ("#\." equivalence)]] + ["." macro + [syntax (#+ syntax:)] + ["." code] + ["." template]] + ["." math + ["." random] + [number + ["n" nat]]]] + {1 + ["." /]}) + +(template.with_locals [g!Foo g!Bar] + (as_is (template [<syntax> <meta>] + [(syntax: (<syntax>) + (do meta.monad + [frame <meta>] + (wrap (list (code.text (get@ #/.name frame))))))] + + [current /.current] + [specific (/.specific (template.text [g!Foo]))] + ) + + (syntax: (with_no_active_frames macro) + (function (_ compiler) + (let [verdict (case ((macro.expand macro) compiler) + (#try.Failure error) + (exception.match? /.no_active_frames error) + + (#try.Success _) + false)] + (#try.Success [compiler (list (code.bit verdict))])))) + + (with_expansions [no_current! (..with_no_active_frames (..current)) + no_specific! (..with_no_active_frames (..specific))] + (/.abstract: (g!Foo a) + Text + + (/.abstract: (g!Bar a) + Nat + + (def: #export test + Test + (<| (_.covering /._) + (_.for [/.abstract:]) + (do random.monad + [expected_foo (random.ascii/lower 5) + expected_bar random.nat] + ($_ _.and + (_.cover [/.:abstraction] + (and (exec (: (g!Foo Text) + (/.:abstraction g!Foo expected_foo)) + true) + (exec (: (g!Bar Text) + (/.:abstraction expected_bar)) + true))) + (_.cover [/.:representation] + (and (|> expected_foo + (/.:abstraction g!Foo) + (: (g!Foo Bit)) + (/.:representation g!Foo) + (text\= expected_foo)) + (|> (/.:abstraction expected_bar) + (: (g!Bar Bit)) + /.:representation + (n.= expected_bar)))) + (_.cover [/.:transmutation] + (and (exec (|> expected_foo + (/.:abstraction g!Foo) + (: (g!Foo .Macro)) + (/.:transmutation g!Foo) + (: (g!Foo .Lux))) + true) + (exec (|> (/.:abstraction expected_bar) + (: (g!Bar .Macro)) + /.:transmutation + (: (g!Bar .Lux))) + true))) + (_.cover [/.^:representation] + (and (let [(/.^:representation g!Foo actual_foo) + (: (g!Foo .Module) + (/.:abstraction g!Foo expected_foo))] + (text\= expected_foo actual_foo)) + (let [(/.^:representation actual_bar) + (: (g!Bar .Module) + (/.:abstraction expected_bar))] + (n.= expected_bar actual_bar)))) + (_.for [/.Frame] + ($_ _.and + (_.cover [/.current] + (text\= (template.text [g!Bar]) + (..current))) + (_.cover [/.specific] + (text\= (template.text [g!Foo]) + (..specific))) + (_.cover [/.no_active_frames] + (and no_current! + no_specific!)) + )) + ))))))))) |