diff options
author | Eduardo Julian | 2020-05-11 23:07:20 -0400 |
---|---|---|
committer | Eduardo Julian | 2020-05-11 23:07:20 -0400 |
commit | 33090b088deb20180108e6713309e0dfc627c6e5 (patch) | |
tree | 1f76aaefe23ce5cecbd3c0f1c1eab3c630ed6cf1 | |
parent | 5e31528ee33b1b6aceac4dc2eeda82f44e463df3 (diff) |
Now storing and loading extensions in the cache.
Diffstat (limited to '')
-rw-r--r-- | documentation/research/web_framework.md | 1 | ||||
-rw-r--r-- | stdlib/source/lux/abstract/monad.lux | 4 | ||||
-rw-r--r-- | stdlib/source/lux/abstract/order.lux | 7 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 49 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/generation.lux | 22 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux | 16 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux | 77 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/meta/archive/artifact.lux | 117 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/meta/io/archive.lux | 169 | ||||
-rw-r--r-- | stdlib/source/test/lux/abstract.lux | 6 | ||||
-rw-r--r-- | stdlib/source/test/lux/abstract/monad.lux | 109 | ||||
-rw-r--r-- | stdlib/source/test/lux/abstract/order.lux | 39 |
12 files changed, 454 insertions, 162 deletions
diff --git a/documentation/research/web_framework.md b/documentation/research/web_framework.md index e6c8554fe..ed293a767 100644 --- a/documentation/research/web_framework.md +++ b/documentation/research/web_framework.md @@ -114,6 +114,7 @@ # Styling +1. [Layout-isolated components](https://visly.app/blog/layout-isolated-components) 1. [Centering in CSS: A Complete Guide](https://css-tricks.com/centering-css-complete-guide/) 1. [Vertical Rhythm Reset](https://jhildenbiddle.github.io/vertical-rhythm-reset/) 1. [Cascading Scoped Style Sheets, aka CSSS, aka C3S](https://github.com/crislin2046/c3s) 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)))))) |