aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/abstract/monad.lux4
-rw-r--r--stdlib/source/lux/abstract/order.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux49
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/generation.lux22
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux77
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/artifact.lux117
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux169
-rw-r--r--stdlib/source/test/lux/abstract.lux6
-rw-r--r--stdlib/source/test/lux/abstract/monad.lux109
-rw-r--r--stdlib/source/test/lux/abstract/order.lux39
11 files changed, 453 insertions, 162 deletions
diff --git a/stdlib/source/lux/abstract/monad.lux b/stdlib/source/lux/abstract/monad.lux
index 5aec10012..491f9b6a2 100644
--- a/stdlib/source/lux/abstract/monad.lux
+++ b/stdlib/source/lux/abstract/monad.lux
@@ -128,12 +128,12 @@
(!@map (|>> (#.Cons _x)) (recur xs'))))
!@join)))))
-(def: #export (filter Monad<!> f)
+(def: #export (filter monad f)
{#.doc "Filter the values in a list with a monadic function."}
(All [! a b]
(-> (Monad !) (-> a (! Bit)) (List a)
(! (List a))))
- (let [(^open "!@.") Monad<!>]
+ (let [(^open "!@.") monad]
(function (recur xs)
(case xs
#.Nil
diff --git a/stdlib/source/lux/abstract/order.lux b/stdlib/source/lux/abstract/order.lux
index 5634aac80..c28026036 100644
--- a/stdlib/source/lux/abstract/order.lux
+++ b/stdlib/source/lux/abstract/order.lux
@@ -44,10 +44,13 @@
Choice
(if (:: order < y x) y x))
-(structure: #export contravariant (Contravariant Order)
+(structure: #export contravariant
+ (Contravariant Order)
+
(def: (map-1 f order)
(structure
- (def: &equivalence (:: equivalence.contravariant map-1 f (:: order &equivalence)))
+ (def: &equivalence
+ (:: equivalence.contravariant map-1 f (:: order &equivalence)))
(def: (< reference sample)
(:: order < (f reference) (f sample))))))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 8e4946966..26a301f86 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -15,6 +15,7 @@
["." text
["%" format (#+ format)]]
[collection
+ [dictionary (#+ Dictionary)]
["." row]
["." set]
["." list ("#@." monoid)]]
@@ -33,10 +34,11 @@
["." syntax]
["#." analysis
[macro (#+ Expander)]]
+ ["#." synthesis]
["#." generation (#+ Buffer)]
["#." directive]
[phase
- [extension (#+ Extender)]
+ ["." extension (#+ Extender)]
[analysis
["." module]]]]]
[meta
@@ -137,6 +139,40 @@
(archive.add archive.runtime-module descriptor,document archive)))]
(wrap [archive [descriptor,document payload]])))
+ (def: (initialize-state extender
+ [analysers
+ synthesizers
+ generators
+ directives]
+ analysis-state
+ state)
+ (All [<type-vars>]
+ (-> Extender
+ [(Dictionary Text ///analysis.Handler)
+ (Dictionary Text ///synthesis.Handler)
+ (Dictionary Text ///generation.Handler)
+ (Dictionary Text ///directive.Handler)]
+ .Lux
+ <State+>
+ (Try <State+>)))
+ (|> (:share [<type-vars>]
+ {<State+>
+ state}
+ {(///directive.Operation <type-vars> Any)
+ (do ///phase.monad
+ [_ (///directive.lift-analysis
+ (///analysis.install analysis-state))
+ _ (///directive.lift-analysis
+ (extension.with extender analysers))
+ _ (///directive.lift-synthesis
+ (extension.with extender synthesizers))
+ _ (///directive.lift-generation
+ (extension.with extender (:assume generators)))
+ _ (extension.with extender (:assume directives))]
+ (wrap []))})
+ (///phase.run' state)
+ (:: try.monad map product.left)))
+
(def: #export (initialize extension target host module expander host-analysis platform generation-bundle host-directive-bundle program extender)
(All [<type-vars>]
(-> Text
@@ -163,15 +199,8 @@
program
extender)]
_ (ioW.enable (get@ #&file-system platform) host target)
- [archive analysis-state] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target)
- [state _] (|> (:share [<type-vars>]
- {<State+>
- state}
- {(///directive.Operation <type-vars> Any)
- (///directive.lift-analysis
- (///analysis.install analysis-state))})
- (///phase.run' state)
- promise@wrap)]
+ [archive analysis-state bundles] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target)
+ state (promise@wrap (initialize-state extender bundles analysis-state state))]
(if (archive.archived? archive archive.runtime-module)
(wrap [state archive])
(do (try.with promise.monad)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
index e787b032d..336e4913a 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
@@ -221,13 +221,21 @@
#.None
(phase.throw ..no-buffer-for-saving-code [name]))))
-(def: #export (learn name)
- (All [anchor expression directive]
- (-> Text (Operation anchor expression directive artifact.ID)))
- (function (_ (^@ stateE [bundle state]))
- (let [[id registry'] (artifact.definition name (get@ #registry state))]
- (#try.Success [[bundle (set@ #registry registry' state)]
- id]))))
+(template [<name> <artifact>]
+ [(def: #export (<name> name)
+ (All [anchor expression directive]
+ (-> Text (Operation anchor expression directive artifact.ID)))
+ (function (_ (^@ stateE [bundle state]))
+ (let [[id registry'] (<artifact> name (get@ #registry state))]
+ (#try.Success [[bundle (set@ #registry registry' state)]
+ id]))))]
+
+ [learn artifact.definition]
+ [learn-analyser artifact.analyser]
+ [learn-synthesizer artifact.synthesizer]
+ [learn-generator artifact.generator]
+ [learn-directive artifact.directive]
+ )
(exception: #export (unknown-definition {name Name}
{known-definitions (List Text)})
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
index 74b47e755..8498c0321 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
@@ -1,7 +1,7 @@
(.module:
[lux (#- Name)
[abstract
- [monad (#+ do)]]
+ ["." monad (#+ do)]]
[control
["." function]
["." try (#+ Try)]
@@ -77,7 +77,17 @@
[]])
_
- (exception.throw cannot-overwrite name))))
+ (exception.throw ..cannot-overwrite name))))
+
+(def: #export (with extender extensions)
+ (All [s i o]
+ (-> Extender (Dictionary Text (Handler s i o)) (Operation s i o Any)))
+ (|> extensions
+ dictionary.entries
+ (monad.fold //.monad
+ (function (_ [extension handle] output)
+ (..install extender extension handle))
+ [])))
(def: #export (apply archive phase [name parameters])
(All [s i o]
@@ -89,7 +99,7 @@
stateE)
#.None
- (exception.throw unknown [name bundle]))))
+ (exception.throw ..unknown [name bundle]))))
(def: #export (localized get set transform)
(All [s s' i o v]
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
index d8cba75ff..f7099d2c4 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
@@ -95,7 +95,7 @@
Name
Type
Synthesis
- (Operation anchor expression directive [Type expression Text Any])))
+ (Operation anchor expression directive [Type expression Any])))
(/////directive.lift-generation
(do phase.monad
[codeG (generate archive codeS)
@@ -103,12 +103,12 @@
module-id (phase.lift (archive.id module archive))
[target-name value directive] (/////generation.define! [module-id id] codeG)
_ (/////generation.save! false [(%.nat module-id) (%.nat id)] directive)]
- (wrap [code//type codeG target-name value]))))
+ (wrap [code//type codeG value]))))
(def: (definition archive name expected codeC)
(All [anchor expression directive]
(-> Archive Name (Maybe Type) Code
- (Operation anchor expression directive [Type expression Text Any])))
+ (Operation anchor expression directive [Type expression Any])))
(do phase.monad
[state (///.lift phase.get-state)
#let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
@@ -135,6 +135,52 @@
(synthesize archive codeA))]
(definition' archive generate name code//type codeS)))
+(template [<full> <partial> <learn>]
+ [## TODO: Inline "<partial>" into "<full>" ASAP
+ (def: (<partial> archive generate extension codeT codeS)
+ (All [anchor expression directive]
+ (-> Archive
+ (/////generation.Phase anchor expression directive)
+ Text
+ Type
+ Synthesis
+ (Operation anchor expression directive [expression Any])))
+ (do phase.monad
+ [current-module (/////directive.lift-analysis
+ (///.lift macro.current-module-name))]
+ (/////directive.lift-generation
+ (do phase.monad
+ [codeG (generate archive codeS)
+ module-id (phase.lift (archive.id current-module archive))
+ id (<learn> extension)
+ [target-name value directive] (/////generation.define! [module-id id] codeG)
+ _ (/////generation.save! false [(%.nat module-id) (%.nat id)] directive)]
+ (wrap [codeG value])))))
+
+ (def: (<full> archive extension codeT codeC)
+ (All [anchor expression directive]
+ (-> Archive Text Type Code
+ (Operation anchor expression directive [expression Any])))
+ (do phase.monad
+ [state (///.lift phase.get-state)
+ #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
+ synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
+ generate (get@ [#/////directive.generation #/////directive.phase] state)]
+ [_ codeA] (/////directive.lift-analysis
+ (/////analysis.with-scope
+ (typeA.with-fresh-env
+ (typeA.with-type codeT
+ (analyse archive codeC)))))
+ codeS (/////directive.lift-synthesis
+ (synthesize archive codeA))]
+ (<partial> archive generate extension codeT codeS)))]
+
+ [analyser analyser' /////generation.learn-analyser]
+ [synthesizer synthesizer' /////generation.learn-synthesizer]
+ [generator generator' /////generation.learn-generator]
+ [directive directive' /////generation.learn-directive]
+ )
+
(def: (refresh expander host-analysis)
(All [anchor expression directive]
(-> Expander /////analysis.Bundle (Operation anchor expression directive Any)))
@@ -160,7 +206,7 @@
[current-module (/////directive.lift-analysis
(///.lift macro.current-module-name))
#let [full-name [current-module short-name]]
- [type valueT valueN value] (..definition archive full-name #.None valueC)
+ [type valueT value] (..definition archive full-name #.None valueC)
[_ annotationsT annotations] (evaluate! archive Code annotationsC)
_ (/////directive.lift-analysis
(module.define short-name (#.Right [exported? type (:coerce Code annotations) value])))
@@ -182,7 +228,7 @@
#let [full-name [current-module short-name]]
[_ annotationsT annotations] (evaluate! archive Code annotationsC)
#let [annotations (:coerce Code annotations)]
- [type valueT valueN value] (..definition archive full-name (#.Some .Type) valueC)
+ [type valueT value] (..definition archive full-name (#.Some .Type) valueC)
_ (/////directive.lift-analysis
(do phase.monad
[_ (module.define short-name (#.Right [exported? type annotations value]))]
@@ -248,7 +294,7 @@
(define-alias alias def-name)))]
(wrap /////directive.no-requirements)))]))
-(template [<description> <mame> <type> <scope>]
+(template [<description> <mame> <type> <scope> <definer>]
[(def: (<mame> extender)
(All [anchor expression directive]
(-> Extender
@@ -258,11 +304,12 @@
(^ (list nameC valueC))
(do phase.monad
[[_ _ name] (evaluate! archive Text nameC)
- [_ _ handlerV] (evaluate! archive (:by-example [anchor expression directive]
- {(Handler anchor expression directive)
- handler}
- <type>)
- valueC)
+ [_ handlerV] (<definer> archive (:coerce Text name)
+ (:by-example [anchor expression directive]
+ {(Handler anchor expression directive)
+ handler}
+ <type>)
+ valueC)
_ (<| <scope>
(///.install extender (:coerce Text name))
(:share [anchor expression directive]
@@ -276,10 +323,10 @@
_
(phase.throw ///.invalid-syntax [extension-name %.code inputsC+]))))]
- ["Analysis" def::analysis /////analysis.Handler /////directive.lift-analysis]
- ["Synthesis" def::synthesis /////synthesis.Handler /////directive.lift-synthesis]
- ["Generation" def::generation (/////generation.Handler anchor expression directive) /////directive.lift-generation]
- ["Directive" def::directive (/////directive.Handler anchor expression directive) (<|)]
+ ["Analysis" def::analysis /////analysis.Handler /////directive.lift-analysis ..analyser]
+ ["Synthesis" def::synthesis /////synthesis.Handler /////directive.lift-synthesis ..synthesizer]
+ ["Generation" def::generation (/////generation.Handler anchor expression directive) /////directive.lift-generation ..generator]
+ ["Directive" def::directive (/////directive.Handler anchor expression directive) (<|) ..directive]
)
## TODO; Both "prepare-program" and "define-program" exist only
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
index cae8c34dc..113d834dc 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
@@ -3,11 +3,14 @@
[abstract
[monad (#+ do)]]
[control
+ [pipe (#+ case>)]
+ ["." exception (#+ exception:)]
["<>" parser
["<b>" binary (#+ Parser)]]]
[data
["." product]
- ["." text]
+ ["." text
+ ["%" format (#+ format)]]
[collection
["." list]
["." row (#+ Row) ("#@." functor fold)]
@@ -19,9 +22,17 @@
(type: #export ID Nat)
+(type: #export Category
+ #Anonymous
+ (#Definition Text)
+ (#Analyser Text)
+ (#Synthesizer Text)
+ (#Generator Text)
+ (#Directive Text))
+
(type: #export Artifact
{#id ID
- #name (Maybe Text)})
+ #category Category})
(abstract: #export Registry
{}
@@ -49,27 +60,37 @@
(|> registry
:representation
(update@ #artifacts (row.add {#id id
- #name #.None}))
+ #category #Anonymous}))
:abstraction)]))
- (def: #export (definition name registry)
- (-> Text Registry [ID Registry])
- (let [id (..next registry)]
- [id
+ (template [<tag> <create> <fetch>]
+ [(def: #export (<create> name registry)
+ (-> Text Registry [ID Registry])
+ (let [id (..next registry)]
+ [id
+ (|> registry
+ :representation
+ (update@ #artifacts (row.add {#id id
+ #category (<tag> name)}))
+ (update@ #resolver (dictionary.put name id))
+ :abstraction)]))
+
+ (def: #export (<fetch> registry)
+ (-> Registry (List Text))
(|> registry
:representation
- (update@ #artifacts (row.add {#id id
- #name (#.Some name)}))
- (update@ #resolver (dictionary.put name id))
- :abstraction)]))
+ (get@ #artifacts)
+ row.to-list
+ (list.search-all (|>> (get@ #category)
+ (case> (<tag> name) (#.Some name)
+ _ #.None)))))]
- (def: #export (definitions registry)
- (-> Registry (List Text))
- (|> registry
- :representation
- (get@ #artifacts)
- row.to-list
- (list.search-all (get@ #name))))
+ [#Definition definition definitions]
+ [#Analyser analyser analysers]
+ [#Synthesizer synthesizer synthesizers]
+ [#Generator generator generators]
+ [#Directive directive directives]
+ )
(def: #export (remember name registry)
(-> Text Registry (Maybe ID))
@@ -79,22 +100,56 @@
(def: #export writer
(Writer Registry)
- (let [writer|artifacts (binary.row/64 (binary.maybe binary.text))]
+ (let [category (: (Writer Category)
+ (function (_ value)
+ (case value
+ (^template [<nat> <tag> <writer>]
+ (<tag> value) ((binary.and binary.nat <writer>) [<nat> value]))
+ ([0 #Anonymous binary.any]
+ [1 #Definition binary.text]
+ [2 #Analyser binary.text]
+ [3 #Synthesizer binary.text]
+ [4 #Generator binary.text]
+ [5 #Directive binary.text]))))
+ artifacts (: (Writer (Row Category))
+ (binary.row/64 category))]
(|>> :representation
(get@ #artifacts)
- (row@map (get@ #name))
- writer|artifacts)))
+ (row@map (get@ #category))
+ artifacts)))
+
+ (exception: #export (invalid-category {tag Nat})
+ (exception.report
+ ["Tag" (%.nat tag)]))
(def: #export parser
(Parser Registry)
- (|> (<b>.row/64 (<b>.maybe <b>.text))
- (:: <>.monad map (row@fold (function (_ artifact registry)
- (product.right
- (case artifact
- #.None
- (..resource registry)
-
- (#.Some name)
- (..definition name registry))))
- ..empty))))
+ (let [category (: (Parser Category)
+ (do <>.monad
+ [tag <b>.nat]
+ (case tag
+ 0 (:: @ map (|>> #Anonymous) <b>.any)
+ 1 (:: @ map (|>> #Definition) <b>.text)
+ 2 (:: @ map (|>> #Analyser) <b>.text)
+ 3 (:: @ map (|>> #Synthesizer) <b>.text)
+ 4 (:: @ map (|>> #Generator) <b>.text)
+ 5 (:: @ map (|>> #Directive) <b>.text)
+ _ (<>.fail (exception.construct ..invalid-category [tag])))))]
+ (|> (<b>.row/64 category)
+ (:: <>.monad map (row@fold (function (_ artifact registry)
+ (product.right
+ (case artifact
+ #Anonymous
+ (..resource registry)
+
+ (^template [<tag> <create>]
+ (<tag> name)
+ (<create> name registry))
+ ([#Definition ..definition]
+ [#Analyser ..analyser]
+ [#Synthesizer ..synthesizer]
+ [#Generator ..generator]
+ [#Directive ..directive])
+ )))
+ ..empty)))))
)
diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
index 9ee78c34a..3cf3ed4c4 100644
--- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
@@ -18,7 +18,7 @@
["." text ("#@." equivalence)
["%" format (#+ format)]]
[collection
- ["." list ("#@." functor)]
+ ["." list ("#@." functor fold)]
["." dictionary (#+ Dictionary)]
["." row (#+ Row)]]]
[world
@@ -36,7 +36,9 @@
["$" lux
["." version]
["." analysis]
- ["." generation]]]]]])
+ ["." synthesis]
+ ["." generation]
+ ["." directive]]]]]])
(exception: #export (cannot-prepare {archive Path}
{module-id archive.ID}
@@ -183,39 +185,104 @@
(wrap [name data]))))
(:: @ map (dictionary.from-list text.hash)))))
+(type: Definitions (Dictionary Text Any))
+(type: Analysers (Dictionary Text analysis.Handler))
+(type: Synthesizers (Dictionary Text synthesis.Handler))
+(type: Generators (Dictionary Text generation.Handler))
+(type: Directives (Dictionary Text directive.Handler))
+
+(type: Bundles
+ [Analysers
+ Synthesizers
+ Generators
+ Directives])
+
+(def: empty-bundles
+ Bundles
+ [(dictionary.new text.hash)
+ (dictionary.new text.hash)
+ (dictionary.new text.hash)
+ (dictionary.new text.hash)])
+
(def: (loaded-document extension host module-id expected actual document)
(All [expression directive]
(-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module)
- (Try (Document .Module))))
+ (Try [(Document .Module) Bundles])))
(do try.monad
- [values (: (Try (Dictionary Text Any))
- (loop [input (row.to-list expected)
- values (: (Dictionary Text Any)
- (dictionary.new text.hash))]
- (case input
- (#.Cons [[artifact-id artifact-name] input'])
- (case (do @
- [data (try.from-maybe (dictionary.get (format (%.nat artifact-id) extension) actual))
- #let [context [module-id artifact-id]
- directive (:: host ingest context data)]]
- (case artifact-name
- #.None
- (do @
- [_ (:: host re-learn context directive)]
- (wrap values))
-
- (#.Some artifact-name)
- (do @
- [value (:: host re-load context directive)]
- (wrap (dictionary.put artifact-name value values)))))
- (#try.Success values')
- (recur input' values')
+ [[definitions bundles] (: (Try [Definitions Bundles])
+ (loop [input (row.to-list expected)
+ definitions (: Definitions
+ (dictionary.new text.hash))
+ bundles ..empty-bundles]
+ (let [[analysers synthesizers generators directives] bundles]
+ (case input
+ (#.Cons [[artifact-id artifact-category] input'])
+ (case (do @
+ [data (try.from-maybe (dictionary.get (format (%.nat artifact-id) extension) actual))
+ #let [context [module-id artifact-id]
+ directive (:: host ingest context data)]]
+ (case artifact-category
+ #artifact.Anonymous
+ (do @
+ [_ (:: host re-learn context directive)]
+ (wrap [definitions
+ [analysers
+ synthesizers
+ generators
+ directives]]))
+
+ (#artifact.Definition name)
+ (do @
+ [value (:: host re-load context directive)]
+ (wrap [(dictionary.put name value definitions)
+ [analysers
+ synthesizers
+ generators
+ directives]]))
+
+ (#artifact.Analyser extension)
+ (do @
+ [value (:: host re-load context directive)]
+ (wrap [definitions
+ [(dictionary.put extension (:coerce analysis.Handler value) analysers)
+ synthesizers
+ generators
+ directives]]))
+
+ (#artifact.Synthesizer extension)
+ (do @
+ [value (:: host re-load context directive)]
+ (wrap [definitions
+ [analysers
+ (dictionary.put extension (:coerce synthesis.Handler value) synthesizers)
+ generators
+ directives]]))
+
+ (#artifact.Generator extension)
+ (do @
+ [value (:: host re-load context directive)]
+ (wrap [definitions
+ [analysers
+ synthesizers
+ (dictionary.put extension (:coerce generation.Handler value) generators)
+ directives]]))
+
+ (#artifact.Directive extension)
+ (do @
+ [value (:: host re-load context directive)]
+ (wrap [definitions
+ [analysers
+ synthesizers
+ generators
+ (dictionary.put extension (:coerce directive.Handler value) directives)]]))))
+ (#try.Success [definitions' bundles'])
+ (recur input' definitions' bundles')
- failure
- failure)
-
- #.None
- (#try.Success values))))
+ failure
+ failure)
+
+ #.None
+ (#try.Success [definitions bundles])))))
content (document.read $.key document)
definitions (monad.map @ (function (_ [def-name def-global])
(case def-global
@@ -224,25 +291,30 @@
(#.Definition [exported? type annotations _])
(do @
- [value (try.from-maybe (dictionary.get def-name values))]
+ [value (try.from-maybe (dictionary.get def-name definitions))]
(wrap [def-name (#.Definition [exported? type annotations value])]))))
(get@ #.definitions content))]
- (wrap (document.write $.key (set@ #.definitions definitions content)))))
+ (wrap [(document.write $.key (set@ #.definitions definitions content))
+ bundles])))
(def: (load-definitions system host root module-id extension host-environment [descriptor document])
(All [expression directive]
(-> (file.System Promise) Host Path archive.ID Text (generation.Host expression directive)
[Descriptor (Document .Module)]
- (Promise (Try [Descriptor (Document .Module)]))))
+ (Promise (Try [[Descriptor (Document .Module)]
+ Bundles]))))
(do (try.with promise.monad)
[actual (cached-artifacts system host root module-id)
#let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)]
- document (promise@wrap (loaded-document extension host-environment module-id expected actual document))]
- (wrap [descriptor document])))
+ [document bundles] (promise@wrap (loaded-document extension host-environment module-id expected actual document))]
+ (wrap [[descriptor document] bundles])))
(def: (load-every-reserved-module extension host-environment system host root archive)
(All [expression directive]
- (-> Text (generation.Host expression directive) (file.System Promise) Host Path Archive (Promise (Try [Archive .Lux]))))
+ (-> Text (generation.Host expression directive) (file.System Promise) Host Path Archive
+ (Promise (Try [Archive
+ .Lux
+ Bundles]))))
(do (try.with promise.monad)
[pre-loaded-caches (|> archive
archive.reservations
@@ -261,23 +333,35 @@
promise@wrap)
loaded-caches (monad.map @ (function (_ [module-name [module-id descriptor,document]])
(do @
- [descriptor,document (..load-definitions system host root module-id extension host-environment descriptor,document)]
- (wrap [module-name descriptor,document])))
+ [[descriptor,document bundles] (..load-definitions system host root module-id extension host-environment descriptor,document)]
+ (wrap [[module-name descriptor,document]
+ bundles])))
load-order)]
(promise@wrap
(do try.monad
[archive (monad.fold try.monad
- (function (_ [module descriptor,document] archive)
+ (function (_ [[module descriptor,document] _bundle] archive)
(archive.add module descriptor,document archive))
archive
loaded-caches)
analysis-state (..analysis-state host archive)]
(wrap [archive
- analysis-state])))))
+ analysis-state
+ (list@fold (function (_ [_ [+analysers +synthesizers +generators +directives]]
+ [analysers synthesizers generators directives])
+ [(dictionary.merge +analysers analysers)
+ (dictionary.merge +synthesizers synthesizers)
+ (dictionary.merge +generators generators)
+ (dictionary.merge +directives directives)])
+ ..empty-bundles
+ loaded-caches)])))))
(def: #export (thaw extension host-environment system host root)
(All [expression directive]
- (-> Text (generation.Host expression directive) (file.System Promise) Host Path (Promise (Try [Archive .Lux]))))
+ (-> Text (generation.Host expression directive) (file.System Promise) Host Path
+ (Promise (Try [Archive
+ .Lux
+ Bundles]))))
(do promise.monad
[file (!.use (:: system file) (..general-descriptor system host root))]
(case file
@@ -289,4 +373,5 @@
(#try.Failure error)
(wrap (#try.Success [archive.empty
- (fresh-analysis-state host)])))))
+ (fresh-analysis-state host)
+ ..empty-bundles])))))
diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux
index d927dcd3e..4becb6344 100644
--- a/stdlib/source/test/lux/abstract.lux
+++ b/stdlib/source/test/lux/abstract.lux
@@ -5,7 +5,10 @@
["#." codec]
["#." enum]
["#." equivalence]
+ ["#." fold]
+ ["#." functor]
["#." interval]
+ ["#." monad]
["#." order]
["#." predicate]])
@@ -15,7 +18,10 @@
/codec.test
/enum.test
/equivalence.test
+ /fold.test
+ /functor.test
/interval.test
+ /monad.test
/order.test
/predicate.test
))
diff --git a/stdlib/source/test/lux/abstract/monad.lux b/stdlib/source/test/lux/abstract/monad.lux
index ecb292afb..4d85a6e90 100644
--- a/stdlib/source/test/lux/abstract/monad.lux
+++ b/stdlib/source/test/lux/abstract/monad.lux
@@ -1,61 +1,110 @@
(.module:
[lux #*
[data
+ ["." identity (#+ Identity)]
[number
["n" nat]]
- [text
- ["%" format (#+ format)]]]
- [control
- ["." function]]
+ [collection
+ ["." list ("#@." functor fold)]]]
[math
- ["r" random]]
+ ["." random]]
["_" test (#+ Test)]]
{1
["." / (#+ Monad do)]}
[//
[functor (#+ Injection Comparison)]])
-(def: (left-identity injection comparison (^open "_;."))
+(def: (left-identity injection comparison (^open "_@."))
(All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
- (do r.monad
- [sample r.nat
+ (do random.monad
+ [sample random.nat
morphism (:: @ map (function (_ diff)
- (|>> (n.+ diff) _;wrap))
- r.nat)]
+ (|>> (n.+ diff) _@wrap))
+ random.nat)]
(_.test "Left identity."
((comparison n.=)
- (|> (injection sample) (_;map morphism) _;join)
+ (|> (injection sample) (_@map morphism) _@join)
(morphism sample)))))
-(def: (right-identity injection comparison (^open "_;."))
+(def: (right-identity injection comparison (^open "_@."))
(All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
- (do r.monad
- [sample r.nat]
+ (do random.monad
+ [sample random.nat]
(_.test "Right identity."
((comparison n.=)
- (|> (injection sample) (_;map _;wrap) _;join)
+ (|> (injection sample) (_@map _@wrap) _@join)
(injection sample)))))
-(def: (associativity injection comparison (^open "_;."))
+(def: (associativity injection comparison (^open "_@."))
(All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
- (do r.monad
- [sample r.nat
+ (do random.monad
+ [sample random.nat
increase (:: @ map (function (_ diff)
- (|>> (n.+ diff) _;wrap))
- r.nat)
+ (|>> (n.+ diff) _@wrap))
+ random.nat)
decrease (:: @ map (function (_ diff)
- (|>> (n.- diff) _;wrap))
- r.nat)]
+ (|>> (n.- diff) _@wrap))
+ random.nat)]
(_.test "Associativity."
((comparison n.=)
- (|> (injection sample) (_;map increase) _;join (_;map decrease) _;join)
- (|> (injection sample) (_;map (|>> increase (_;map decrease) _;join)) _;join)))))
+ (|> (injection sample) (_@map increase) _@join (_@map decrease) _@join)
+ (|> (injection sample) (_@map (|>> increase (_@map decrease) _@join)) _@join)))))
(def: #export (spec injection comparison monad)
(All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
- (_.context (%.name (name-of /.Monad))
- ($_ _.and
- (..left-identity injection comparison monad)
- (..right-identity injection comparison monad)
- (..associativity injection comparison monad)
- )))
+ (<| (_.with-cover [/.Monad])
+ ($_ _.and
+ (..left-identity injection comparison monad)
+ (..right-identity injection comparison monad)
+ (..associativity injection comparison monad)
+ )))
+
+(def: #export test
+ Test
+ (do random.monad
+ [mono random.nat
+ poly (random.list 10 random.nat)]
+ (<| (_.covering /._)
+ ($_ _.and
+ (_.cover [/.do]
+ (n.= (inc mono)
+ (: (Identity Nat)
+ (/.do identity.monad
+ [sample (wrap mono)]
+ (wrap (inc sample))))))
+ (_.cover [/.bind]
+ (n.= (inc mono)
+ (: (Identity Nat)
+ (/.bind identity.monad
+ (|>> inc (:: identity.monad wrap))
+ (:: identity.monad wrap mono)))))
+ (_.cover [/.seq]
+ (:: (list.equivalence n.equivalence) =
+ (list@map inc poly)
+ (|> poly
+ (list@map (|>> inc (:: identity.monad wrap)))
+ (: (List (Identity Nat)))
+ (/.seq identity.monad)
+ (: (Identity (List Nat))))))
+ (_.cover [/.map]
+ (:: (list.equivalence n.equivalence) =
+ (list@map inc poly)
+ (|> poly
+ (/.map identity.monad (|>> inc (:: identity.monad wrap)))
+ (: (Identity (List Nat))))))
+ (_.cover [/.filter]
+ (:: (list.equivalence n.equivalence) =
+ (list.filter n.even? poly)
+ (|> poly
+ (/.filter identity.monad (|>> n.even? (:: identity.monad wrap)))
+ (: (Identity (List Nat))))))
+ (_.cover [/.fold]
+ (n.= (list@fold n.+ 0 poly)
+ (|> poly
+ (/.fold identity.monad
+ (function (_ part whole)
+ (:: identity.monad wrap
+ (n.+ part whole)))
+ 0)
+ (: (Identity Nat)))))
+ ))))
diff --git a/stdlib/source/test/lux/abstract/order.lux b/stdlib/source/test/lux/abstract/order.lux
index ed64b5d46..a92dd06ad 100644
--- a/stdlib/source/test/lux/abstract/order.lux
+++ b/stdlib/source/test/lux/abstract/order.lux
@@ -1,43 +1,42 @@
(.module:
[lux #*
["_" test (#+ Test)]
- [abstract/monad (#+ do)]
+ [abstract
+ [monad (#+ do)]]
[data
- [text
- ["%" format (#+ format)]]
[number
["n" nat]]]
[math
- ["r" random (#+ Random)]]]
+ ["." random (#+ Random)]]]
{1
["." / (#+ Order)]})
(def: #export test
Test
- (<| (_.context (%.name (name-of /.Order)))
- (do r.monad
- [left r.nat
- right (|> r.nat (r.filter (|>> (n.= left) not)))])
+ (<| (_.covering /._)
+ (do random.monad
+ [left random.nat
+ right (|> random.nat (random.filter (|>> (n.= left) not)))])
($_ _.and
- (_.test (format (%.name (name-of /.min)) " &&& " (%.name (name-of /.max)))
- (n.< (/.max n.order left right)
- (/.min n.order left right)))
+ (_.cover [/.Choice /.min /.max]
+ (n.< (/.max n.order left right)
+ (/.min n.order left right)))
)))
-(def: #export (spec (^open ",@.") generator)
+(def: #export (spec (^open "/@.") generator)
(All [a] (-> (Order a) (Random a) Test))
- (<| (_.context (%.name (name-of /.Order)))
- (do r.monad
+ (<| (_.with-cover [/.Order])
+ (do random.monad
[parameter generator
subject generator])
($_ _.and
(_.test "Values are either ordered, or they are equal. All options are mutually exclusive."
- (cond (,@< parameter subject)
- (not (or (,@< subject parameter)
- (,@= parameter subject)))
+ (cond (/@< parameter subject)
+ (not (or (/@< subject parameter)
+ (/@= parameter subject)))
- (,@< subject parameter)
- (not (,@= parameter subject))
+ (/@< subject parameter)
+ (not (/@= parameter subject))
## else
- (,@= parameter subject))))))
+ (/@= parameter subject))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 14:26:22 +0000