aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/tool/compiler/default/init.lux114
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux20
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/generation.lux13
-rw-r--r--stdlib/source/test/lux/control/parser.lux213
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
))))