diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase/generation.lux')
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation.lux | 255 |
1 files changed, 255 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/generation.lux b/stdlib/source/lux/tool/compiler/phase/generation.lux new file mode 100644 index 000000000..99a4c5517 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation.lux @@ -0,0 +1,255 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." error (#+ Error)] + ["." name ("#/." equivalence)] + ["." text + format] + [collection + ["." row (#+ Row)] + ["." dictionary (#+ Dictionary)]]] + [world + [file (#+ Path)]]] + ["." // + ["." extension] + [// + [synthesis (#+ Synthesis)]]]) + +(do-template [<name>] + [(exception: #export (<name>) + "")] + + [no-active-buffer] + [no-anchor] + ) + +(exception: #export (cannot-interpret {error Text}) + (exception.report + ["Error" error])) + +(exception: #export (unknown-lux-name {name Name}) + (exception.report + ["Name" (%name name)])) + +(exception: #export (cannot-overwrite-lux-name {lux-name Name} + {old-host-name Text} + {new-host-name Text}) + (exception.report + ["Lux Name" (%name lux-name)] + ["Old Host Name" old-host-name] + ["New Host Name" new-host-name])) + +(do-template [<name>] + [(exception: #export (<name> {name Name}) + (exception.report + ["Output" (%name name)]))] + + [cannot-overwrite-output] + [no-buffer-for-saving-code] + ) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(signature: #export (Host expression statement) + (: (-> Text expression (Error Any)) + evaluate!) + (: (-> Text statement (Error Any)) + execute!) + (: (-> Name expression (Error [Text Any])) + define!)) + +(type: #export (Buffer statement) (Row [Name statement])) + +(type: #export (Outputs statement) (Dictionary Path (Buffer statement))) + +(type: #export (State anchor expression statement) + {#context Context + #anchor (Maybe anchor) + #host (Host expression statement) + #buffer (Maybe (Buffer statement)) + #outputs (Outputs statement) + #counter Nat + #name-cache (Dictionary Name Text)}) + +(do-template [<special> <general>] + [(type: #export (<special> anchor expression statement) + (<general> (State anchor expression statement) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (state host) + (All [anchor expression statement] + (-> (Host expression statement) + (..State anchor expression statement))) + {#context {#scope-name "" + #inner-functions 0} + #anchor #.None + #host host + #buffer #.None + #outputs (dictionary.new text.hash) + #counter 0 + #name-cache (dictionary.new name.hash)}) + +(def: #export (with-context expr) + (All [anchor expression statement output] + (-> (Operation anchor expression statement output) + (Operation anchor expression statement [Text output]))) + (function (_ [bundle state]) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "c" (%n old-inner))] + (case (expr [bundle (set@ #context [new-scope 0] state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')] + [new-scope output]]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: #export context + (All [anchor expression statement] + (Operation anchor expression statement Text)) + (extension.read (|>> (get@ #context) + (get@ #scope-name)))) + +(do-template [<tag> + <with-declaration> <with-type> <with-value> + <get> <get-type> <exception>] + [(def: #export <with-declaration> + (All [anchor expression statement output] <with-type>) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (set@ <tag> (#.Some <with-value>) state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ <tag> (get@ <tag> state) state')] + output]) + + (#error.Failure error) + (#error.Failure error))))) + + (def: #export <get> + (All [anchor expression statement] + (Operation anchor expression statement <get-type>)) + (function (_ (^@ stateE [bundle state])) + (case (get@ <tag> state) + (#.Some output) + (#error.Success [stateE output]) + + #.None + (exception.throw <exception> []))))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation anchor expression statement output) + (Operation anchor expression statement output)) + anchor + anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation anchor expression statement output) + (Operation anchor expression statement output)) + row.empty + buffer (Buffer statement) no-active-buffer] + ) + +(def: #export outputs + (All [anchor expression statement] + (Operation anchor expression statement (Outputs statement))) + (extension.read (get@ #outputs))) + +(def: #export next + (All [anchor expression statement] + (Operation anchor expression statement Nat)) + (do //.monad + [count (extension.read (get@ #counter)) + _ (extension.update (update@ #counter inc))] + (wrap count))) + +(do-template [<name> <inputT>] + [(def: #export (<name> label code) + (All [anchor expression statement] + (-> Text <inputT> (Operation anchor expression statement Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) <name> label code) + (#error.Success output) + (#error.Success [state+ output]) + + (#error.Failure error) + (exception.throw cannot-interpret error))))] + + [evaluate! expression] + [execute! statement] + ) + +(def: #export (define! name code) + (All [anchor expression statement] + (-> Name expression (Operation anchor expression statement [Text Any]))) + (function (_ (^@ stateE [bundle state])) + (case (:: (get@ #host state) define! name code) + (#error.Success output) + (#error.Success [stateE output]) + + (#error.Failure error) + (exception.throw cannot-interpret error)))) + +(def: #export (save! name code) + (All [anchor expression statement] + (-> Name statement (Operation anchor expression statement Any))) + (do //.monad + [count ..next + _ (execute! (format "save" (%n count)) code) + ?buffer (extension.read (get@ #buffer))] + (case ?buffer + (#.Some buffer) + (if (row.any? (|>> product.left (name/= name)) buffer) + (//.throw cannot-overwrite-output name) + (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) + + #.None + (//.throw no-buffer-for-saving-code name)))) + +(def: #export (save-buffer! target) + (All [anchor expression statement] + (-> Path (Operation anchor expression statement Any))) + (do //.monad + [buffer ..buffer] + (extension.update (update@ #outputs (dictionary.put target buffer))))) + +(def: #export (remember lux-name) + (All [anchor expression statement] + (-> Name (Operation anchor expression statement Text))) + (function (_ (^@ stateE [_ state])) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + (#.Some host-name) + (#error.Success [stateE host-name]) + + #.None + (exception.throw unknown-lux-name lux-name))))) + +(def: #export (learn lux-name host-name) + (All [anchor expression statement] + (-> Name Text (Operation anchor expression statement Any))) + (function (_ [bundle state]) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + #.None + (#error.Success [[bundle + (update@ #name-cache + (dictionary.put lux-name host-name) + state)] + []]) + + (#.Some old-host-name) + (exception.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) |