diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/default/init.lux | 114 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/generation.lux | 13 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/parser.lux | 213 |
4 files changed, 251 insertions, 109 deletions
diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 0b0acd8b0..625931913 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -110,11 +110,15 @@ (All [anchor expression directive] (///directive.Operation anchor expression directive a))) +(type: (Payload directive) + [(///generation.Buffer directive) + artifact.Registry]) + (def: (begin dependencies hash input) (-> (List Module) Nat ///.Input (All [anchor expression directive] (///directive.Operation anchor expression directive - [Source (///generation.Buffer directive)]))) + [Source (Payload directive)]))) (do ///phase.monad [#let [module (get@ #///.module input)] _ (///directive.set-current-module module)] @@ -124,12 +128,13 @@ _ (monad.map @ module.import dependencies) #let [source (///analysis.source (get@ #///.module input) (get@ #///.code input))] _ (///analysis.set-source-code source)] - (wrap [source ///generation.empty-buffer]))))) + (wrap [source [///generation.empty-buffer + artifact.empty]]))))) (def: (end module) (-> Module (All [anchor expression directive] - (///directive.Operation anchor expression directive [.Module (///generation.Buffer directive)]))) + (///directive.Operation anchor expression directive [.Module (Payload directive)]))) (do ///phase.monad [_ (///directive.lift-analysis (module.set-compiled module)) @@ -138,57 +143,67 @@ extension.lift macro.current-module) final-buffer (///directive.lift-generation - ///generation.buffer)] - (wrap [analysis-module final-buffer]))) + ///generation.buffer) + final-registry (///directive.lift-generation + ///generation.get-registry)] + (wrap [analysis-module [final-buffer + final-registry]]))) ## TODO: Inline ASAP -(def: (get-current-buffer old-buffer) +(def: (get-current-payload _) (All [directive] - (-> (///generation.Buffer directive) + (-> (Payload directive) (All [anchor expression] (///directive.Operation anchor expression directive - (///generation.Buffer directive))))) - (///directive.lift-generation - ///generation.buffer)) + (Payload directive))))) + (do ///phase.monad + [buffer (///directive.lift-generation + ///generation.buffer) + registry (///directive.lift-generation + ///generation.get-registry)] + (wrap [buffer registry]))) ## TODO: Inline ASAP -(def: (process-directive archive expander pre-buffer code) +(def: (process-directive archive expander pre-payoad code) (All [directive] - (-> Archive Expander (///generation.Buffer directive) Code + (-> Archive Expander (Payload directive) Code (All [anchor expression] (///directive.Operation anchor expression directive - [Requirements (///generation.Buffer directive)])))) + [Requirements (Payload directive)])))) (do ///phase.monad - [_ (///directive.lift-generation + [#let [[pre-buffer pre-registry] pre-payoad] + _ (///directive.lift-generation (///generation.set-buffer pre-buffer)) + _ (///directive.lift-generation + (///generation.set-registry pre-registry)) requirements (let [execute! (directiveP.phase expander)] (execute! archive code)) - post-buffer (..get-current-buffer pre-buffer)] - (wrap [requirements post-buffer]))) + post-payload (..get-current-payload pre-payoad)] + (wrap [requirements post-payload]))) -(def: (iteration archive expander reader source pre-buffer) +(def: (iteration archive expander reader source pre-payload) (All [directive] - (-> Archive Expander Reader Source (///generation.Buffer directive) + (-> Archive Expander Reader Source (Payload directive) (All [anchor expression] (///directive.Operation anchor expression directive - [Source Requirements (///generation.Buffer directive)])))) + [Source Requirements (Payload directive)])))) (do ///phase.monad [[source code] (///directive.lift-analysis (..read source reader)) - [requirements post-buffer] (process-directive archive expander pre-buffer code)] - (wrap [source requirements post-buffer]))) + [requirements post-payload] (process-directive archive expander pre-payload code)] + (wrap [source requirements post-payload]))) -(def: (iterate archive expander module source pre-buffer aliases) +(def: (iterate archive expander module source pre-payload aliases) (All [directive] - (-> Archive Expander Module Source (///generation.Buffer directive) Aliases + (-> Archive Expander Module Source (Payload directive) Aliases (All [anchor expression] (///directive.Operation anchor expression directive - (Maybe [Source Requirements (///generation.Buffer directive)]))))) + (Maybe [Source Requirements (Payload directive)]))))) (do ///phase.monad [reader (///directive.lift-analysis (..reader module aliases source))] (function (_ state) - (case (///phase.run' state (..iteration archive expander reader source pre-buffer)) + (case (///phase.run' state (..iteration archive expander reader source pre-payload)) (#try.Success [state source&requirements&buffer]) (#try.Success [state (#.Some source&requirements&buffer)]) @@ -224,17 +239,17 @@ (loop [iteration (<| (///phase.run' state) (..iterate archive expander module source buffer ///syntax.no-aliases))] (do @ - [[state ?source&requirements&temporary-buffer] iteration] - (case ?source&requirements&temporary-buffer + [[state ?source&requirements&temporary-payload] iteration] + (case ?source&requirements&temporary-payload #.None (do @ - [[state [analysis-module final-buffer]] (///phase.run' state (..end module)) + [[state [analysis-module [final-buffer final-registry]]] (///phase.run' state (..end module)) #let [descriptor {#descriptor.hash hash #descriptor.name module #descriptor.file (get@ #///.file input) #descriptor.references (set.from-list text.hash dependencies) #descriptor.state #.Compiled - #descriptor.registry artifact.empty}]] + #descriptor.registry final-registry}]] (wrap [state (#.Right [[descriptor (document.write key analysis-module)] (|> final-buffer @@ -242,25 +257,28 @@ [(product.right name) (write-directive directive)])))])])) - (#.Some [source requirements temporary-buffer]) - (wrap [state - (#.Left {#///.dependencies (|> requirements - (get@ #///directive.imports) - (list@map product.left)) - #///.process (function (_ state archive) - (recur (<| (///phase.run' state) - (do ///phase.monad - [analysis-module (<| (: (Operation .Module)) - ///directive.lift-analysis - extension.lift - macro.current-module) - _ (///directive.lift-generation - (///generation.set-buffer temporary-buffer)) - _ (|> requirements - (get@ #///directive.referrals) - (monad.map @ (execute! archive))) - temporary-buffer (..get-current-buffer temporary-buffer)] - (..iterate archive expander module source temporary-buffer (..module-aliases analysis-module))))))})]) + (#.Some [source requirements temporary-payload]) + (let [[temporary-buffer temporary-registry] temporary-payload] + (wrap [state + (#.Left {#///.dependencies (|> requirements + (get@ #///directive.imports) + (list@map product.left)) + #///.process (function (_ state archive) + (recur (<| (///phase.run' state) + (do ///phase.monad + [analysis-module (<| (: (Operation .Module)) + ///directive.lift-analysis + extension.lift + macro.current-module) + _ (///directive.lift-generation + (///generation.set-buffer temporary-buffer)) + _ (///directive.lift-generation + (///generation.set-registry temporary-registry)) + _ (|> requirements + (get@ #///directive.referrals) + (monad.map @ (execute! archive))) + temporary-payload (..get-current-payload temporary-payload)] + (..iterate archive expander module source temporary-payload (..module-aliases analysis-module))))))})])) )))))})))) (def: #export key diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 7419ddac5..1f68030bd 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -52,6 +52,15 @@ #runtime (///generation.Operation anchor expression directive Any) #write (-> directive Binary)}) +## TODO: Get rid of this +(type: (Action a) + (Promise (Try a))) + +## TODO: Get rid of this +(def: monad + (:coerce (Monad Action) + (try.with promise.monad))) + (with-expansions [<type-vars> (as-is [anchor expression directive]) <Platform> (as-is (Platform anchor expression directive)) <State+> (as-is (///directive.State+ anchor expression directive)) @@ -62,18 +71,15 @@ (-> <Platform> Host Path Path archive.ID Text Output (Promise (Try Any)))) (let [system (get@ #&file-system platform) - write-artifact! (: (-> [Text Binary] (Promise (Try Any))) + write-artifact! (: (-> [Text Binary] (Action Any)) (function (_ [name content]) (ioW.write system host target-dir module-id name extension content)))] - (do (try.with promise.monad) + (do ..monad [_ (ioW.prepare system host target-dir module-id) _ (|> output row.to-list - (monad.map promise.monad - write-artifact!) - (: (Promise (List (Try Any)))) - (promise@map (monad.seq try.monad)) - (: (Promise (Try (List Any)))))] + (monad.map ..monad write-artifact!) + (: (Action (List Any))))] (wrap []) ## (&io.write target-dir ## (format module-name "/" cache.descriptor-name) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux index aedb38f61..b428a851d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux @@ -136,6 +136,19 @@ set-buffer buffer (Buffer directive) no-active-buffer] ) +(def: #export get-registry + (All [anchor expression directive] + (Operation anchor expression directive artifact.Registry)) + (function (_ (^@ stateE [bundle state])) + (#try.Success [stateE (get@ #registry state)]))) + +(def: #export (set-registry value) + (All [anchor expression directive] + (-> artifact.Registry (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (#try.Success [[bundle (set@ #registry value state)] + []]))) + (def: #export next (All [anchor expression directive] (Operation anchor expression directive Nat)) diff --git a/stdlib/source/test/lux/control/parser.lux b/stdlib/source/test/lux/control/parser.lux index 58a35ae02..bcb958210 100644 --- a/stdlib/source/test/lux/control/parser.lux +++ b/stdlib/source/test/lux/control/parser.lux @@ -14,14 +14,15 @@ [parser ["s" code]]] [data + ["." name] [number ["n" nat]] - ["." text ("#;." equivalence) + ["." text ("#@." equivalence) ["%" format (#+ format)]] [collection - ["." list ("#;." functor)]]] + ["." list ("#@." functor)]]] [math - ["r" random]] + ["." random]] [macro ["." code] [syntax (#+ syntax:)]]] @@ -32,7 +33,7 @@ (All [a] (-> Text (Try a) Bit)) (case input (#try.Failure actual) - (text;= expected actual) + (text@= expected actual) _ #0)) @@ -74,15 +75,15 @@ (def: combinators-0 Test - (do r.monad - [expected0 r.nat - variadic (:: @ map (|>> (n.max 1) (n.min 20)) r.nat) - expected+ (r.list variadic r.nat) - even0 (r.filter n.even? r.nat) - odd0 (r.filter n.odd? r.nat) - not0 r.bit] + (do random.monad + [expected0 random.nat + variadic (:: @ map (|>> (n.max 1) (n.min 20)) random.nat) + expected+ (random.list variadic random.nat) + even0 (random.filter n.even? random.nat) + odd0 (random.filter n.odd? random.nat) + not0 random.bit] ($_ _.and - (_.test "Can optionally succeed with some parser." + (_.test (%.name (name-of /.maybe)) (and (|> (list (code.nat expected0)) (/.run (/.maybe s.nat)) (match (#.Some actual) @@ -91,17 +92,17 @@ (/.run (/.maybe s.nat)) (match #.None #1)))) - (_.test "Can apply a parser 0 or more times." - (and (|> (list;map code.nat expected+) + (_.test (%.name (name-of /.some)) + (and (|> (list@map code.nat expected+) (/.run (/.some s.nat)) (match actual (:: (list.equivalence n.equivalence) = expected+ actual))) - (|> (list;map (|>> .int code.int) expected+) + (|> (list@map (|>> .int code.int) expected+) (/.run (/.some s.nat)) (match #.Nil #1)))) - (_.test "Can apply a parser 1 or more times." - (and (|> (list;map code.nat expected+) + (_.test (%.name (name-of /.many)) + (and (|> (list@map code.nat expected+) (/.run (/.many s.nat)) (match actual (:: (list.equivalence n.equivalence) = expected+ actual))) @@ -109,10 +110,40 @@ (/.run (/.many s.nat)) (match (list actual) (n.= expected0 actual))) - (|> (list;map (|>> .int code.int) expected+) + (|> (list@map (|>> .int code.int) expected+) (/.run (/.many s.nat)) fails?))) - (_.test "Can use either parser." + (_.test (%.name (name-of /.filter)) + (and (|> (list (code.nat even0)) + (/.run (/.filter n.even? s.nat)) + (match actual (n.= even0 actual))) + (|> (list (code.nat odd0)) + (/.run (/.filter n.even? s.nat)) + fails?))) + (_.test (%.name (name-of /.and)) + (let [even (/.filter n.even? s.nat) + odd (/.filter n.odd? s.nat)] + (and (|> (list (code.nat even0) (code.nat odd0)) + (/.run (/.and even odd)) + (match [left right] + (and (n.= even0 left) + (n.= odd0 right)))) + (|> (list (code.nat odd0) (code.nat even0)) + (/.run (/.and even odd)) + fails?)))) + (_.test (%.name (name-of /.or)) + (let [even (/.filter n.even? s.nat) + odd (/.filter n.odd? s.nat)] + (and (|> (list (code.nat even0)) + (/.run (/.or even odd)) + (match (#.Left actual) (n.= even0 actual))) + (|> (list (code.nat odd0)) + (/.run (/.or even odd)) + (match (#.Right actual) (n.= odd0 actual))) + (|> (list (code.bit not0)) + (/.run (/.or even odd)) + fails?)))) + (_.test (%.name (name-of /.either)) (let [even (/.filter n.even? s.nat) odd (/.filter n.odd? s.nat)] (and (|> (list (code.nat even0)) @@ -124,7 +155,7 @@ (|> (list (code.bit not0)) (/.run (/.either even odd)) fails?)))) - (_.test "Can create the opposite/negation of any parser." + (_.test (%.name (name-of /.not)) (and (|> (list (code.nat expected0)) (/.run (/.not s.nat)) fails?) @@ -135,82 +166,139 @@ (def: combinators-1 Test - (do r.monad - [failure (r.ascii 1) - variadic (:: @ map (|>> (n.max 1) (n.min 20)) r.nat) - times (:: @ map (n.% variadic) r.nat) - expected+ (r.list variadic r.nat) - separator (r.ascii 1)] + (do random.monad + [variadic (:: @ map (|>> (n.max 1) (n.min 20)) random.nat) + times (:: @ map (n.% variadic) random.nat) + expected random.nat + wrong (|> random.nat (random.filter (|>> (n.= expected) not))) + expected+ (random.list variadic random.nat) + separator (random.ascii 1)] ($_ _.and - (_.test "Can fail at will." - (|> (list) - (/.run (/.fail failure)) - (should-fail failure))) - (_.test "Can apply a parser N times." - (and (|> (list;map code.nat expected+) + (_.test (%.name (name-of /.exactly)) + (and (|> (list@map code.nat expected+) (/.run (/.exactly times s.nat)) (match actual (:: (list.equivalence n.equivalence) = (list.take times expected+) actual))) - (|> (list;map code.nat expected+) + (|> (list@map code.nat expected+) (/.run (/.exactly (inc variadic) s.nat)) fails?))) - (_.test "Can apply a parser at-least N times." - (and (|> (list;map code.nat expected+) + (_.test (%.name (name-of /.at-least)) + (and (|> (list@map code.nat expected+) (/.run (/.at-least times s.nat)) (match actual (:: (list.equivalence n.equivalence) = expected+ actual))) - (|> (list;map code.nat expected+) + (|> (list@map code.nat expected+) (/.run (/.at-least (inc variadic) s.nat)) fails?))) - (_.test "Can apply a parser at-most N times." - (and (|> (list;map code.nat expected+) + (_.test (%.name (name-of /.at-most)) + (and (|> (list@map code.nat expected+) (/.run (/.at-most times s.nat)) (match actual (:: (list.equivalence n.equivalence) = (list.take times expected+) actual))) - (|> (list;map code.nat expected+) + (|> (list@map code.nat expected+) (/.run (/.at-most (inc variadic) s.nat)) (match actual (:: (list.equivalence n.equivalence) = expected+ actual))))) - (_.test "Can apply a parser between N and M times." - (and (|> (list;map code.nat expected+) + (_.test (%.name (name-of /.between)) + (and (|> (list@map code.nat expected+) (/.run (/.between times variadic s.nat)) (match actual (:: (list.equivalence n.equivalence) = expected+ actual))) - (|> (list;map code.nat (list.take times expected+)) + (|> (list@map code.nat (list.take times expected+)) (/.run (/.between times variadic s.nat)) (match actual (:: (list.equivalence n.equivalence) = (list.take times expected+) actual))))) - (_.test "Can parse while taking separators into account." - (|> (list.interpose (code.text separator) (list;map code.nat expected+)) + (_.test (%.name (name-of /.sep-by)) + (|> (list.interpose (code.text separator) (list@map code.nat expected+)) (/.run (/.sep-by (s.this! (code.text separator)) s.nat)) (match actual (:: (list.equivalence n.equivalence) = expected+ actual)))) - (_.test "Can obtain the whole of the remaining input." - (|> (list;map code.nat expected+) + (_.test (%.name (name-of /.remaining)) + (|> (list@map code.nat expected+) (/.run /.remaining) (match actual (:: (list.equivalence code.equivalence) = - (list;map code.nat expected+) + (list@map code.nat expected+) actual)))) + (_.test (%.name (name-of /.default)) + (and (|> (/.run (/.default wrong (:: /.monad wrap expected)) (list)) + (match actual (n.= expected actual))) + (|> (/.run (/.default expected (: (Parser (List Code) Nat) + (/.fail "yolo"))) + (list)) + (match actual (n.= expected actual))) + )) + ))) + +(def: combinators-2 + Test + (do random.monad + [expected random.nat + even (random.filter n.even? random.nat) + odd (random.filter n.odd? random.nat) + #let [even^ (/.filter n.even? s.nat) + odd^ (/.filter n.odd? s.nat)]] + ($_ _.and + (_.test (%.name (name-of /.rec)) + (let [parser (/.rec (function (_ self) + (/.either s.nat + (s.tuple self)))) + level-0 (code.nat expected) + level-up (: (-> Code Code) + (|>> list code.tuple))] + (and (|> (list level-0) + (/.run parser) + (match actual (n.= expected actual))) + (|> (list (level-up level-0)) + (/.run parser) + (match actual (n.= expected actual))) + (|> (list (level-up (level-up level-0))) + (/.run parser) + (match actual (n.= expected actual)))))) + (_.test (%.name (name-of /.after)) + (and (|> (/.run (/.after even^ s.nat) + (list (code.nat even) (code.nat expected))) + (match actual (n.= expected actual))) + (|> (/.run (/.after even^ s.nat) + (list (code.nat odd) (code.nat expected))) + fails?))) + (_.test (%.name (name-of /.before)) + (and (|> (/.run (/.before even^ s.nat) + (list (code.nat expected) (code.nat even))) + (match actual (n.= expected actual))) + (|> (/.run (/.before even^ s.nat) + (list (code.nat expected) (code.nat odd))) + fails?))) + (_.test (%.name (name-of /.parses?)) + (and (|> (/.run (/.parses? even^) + (list (code.nat even))) + (match verdict verdict)) + (|> (/.run (/.parses? even^) + (list (code.nat odd))) + (match verdict (not verdict))))) + (_.test (%.name (name-of /.codec)) + (|> (/.run (/.codec n.decimal s.text) + (list (code.text (%.nat expected)))) + (match actual (n.= expected actual)))) ))) -(def: (injection value) +(def: injection (Injection (All [a i] (Parser i a))) - (:: /.monad wrap value)) + (:: /.monad wrap)) (def: comparison (Comparison (All [a i] (Parser i a))) @@ -224,21 +312,38 @@ (def: #export test Test - (do r.monad - [assertion (r.ascii 1)] - (<| (_.context (%.name (name-of /.Parser))) + (do random.monad + [expected random.nat + failure (random.ascii 1) + assertion (random.ascii 1)] + (<| (_.context (name.module (name-of /._))) ($_ _.and ($functor.spec ..injection ..comparison /.functor) ($apply.spec ..injection ..comparison /.apply) ($monad.spec ..injection ..comparison /.monad) - (_.test "Can make assertions while parsing." + (_.test (%.name (name-of /.run)) + (|> (/.run (:: /.monad wrap expected) (list)) + (match actual (n.= expected actual)))) + (_.test (%.name (name-of /.fail)) + (|> (list) + (/.run (/.fail failure)) + (should-fail failure))) + (_.test (%.name (name-of /.lift)) + (and (|> (list) + (/.run (/.lift (#try.Success expected))) + (match actual (n.= expected actual))) + (|> (list) + (/.run (/.lift (#try.Failure failure))) + (should-fail failure)))) + (_.test (%.name (name-of /.assert)) (and (|> (list (code.bit #1) (code.int +123)) (/.run (/.assert assertion #1)) - (match [] #1)) + (match [] true)) (|> (list (code.bit #1) (code.int +123)) (/.run (/.assert assertion #0)) fails?))) ..combinators-0 ..combinators-1 + ..combinators-2 )))) |