diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux (renamed from stdlib/source/lux/tool/compiler/phase/extension/statement.lux) | 232 |
1 files changed, 116 insertions, 116 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux index 992d5a932..0ae210fa5 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux @@ -20,7 +20,7 @@ ["." code]] ["." type (#+ :share :by-example) ("#@." equivalence) ["." check]]] - ["." // + ["." /// ["#." bundle] ["#." analysis] ["#/" // @@ -36,63 +36,79 @@ [default ["#." evaluation]]]]]) +(def: #export (custom [syntax handler]) + (All [anchor expression statement s] + (-> [(Parser s) + (-> Text + (Phase anchor expression statement) + s + (Operation anchor expression statement Requirements))] + (Handler anchor expression statement))) + (function (_ extension-name phase inputs) + (case (s.run syntax inputs) + (#error.Success inputs) + (handler extension-name phase inputs) + + (#error.Failure error) + (////.throw ///.invalid-syntax [extension-name %code inputs])))) + ## TODO: Inline "evaluate!'" into "evaluate!" ASAP (def: (evaluate!' generate code//type codeS) (All [anchor expression statement] - (-> (///generation.Phase anchor expression statement) + (-> (////generation.Phase anchor expression statement) Type Synthesis (Operation anchor expression statement [Type expression Any]))) - (////statement.lift-generation - (do ///.monad + (/////statement.lift-generation + (do ////.monad [codeT (generate codeS) - count ///generation.next - codeV (///generation.evaluate! (format "evaluate" (%n count)) codeT)] + count ////generation.next + codeV (////generation.evaluate! (format "evaluate" (%n count)) codeT)] (wrap [code//type codeT codeV])))) (def: (evaluate! type codeC) (All [anchor expression statement] (-> Type Code (Operation anchor expression statement [Type expression Any]))) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#////statement.analysis #////statement.phase] state) - synthesize (get@ [#////statement.synthesis #////statement.phase] state) - generate (get@ [#////statement.generation #////statement.phase] state)] - [_ codeA] (////statement.lift-analysis - (////analysis.with-scope + (do ////.monad + [state (///.lift ////.get-state) + #let [analyse (get@ [#/////statement.analysis #/////statement.phase] state) + synthesize (get@ [#/////statement.synthesis #/////statement.phase] state) + generate (get@ [#/////statement.generation #/////statement.phase] state)] + [_ codeA] (/////statement.lift-analysis + (/////analysis.with-scope (typeA.with-fresh-env (typeA.with-type type (analyse codeC))))) - codeS (////statement.lift-synthesis + codeS (/////statement.lift-synthesis (synthesize codeA))] (evaluate!' generate type codeS))) ## TODO: Inline "definition'" into "definition" ASAP (def: (definition' generate name code//type codeS) (All [anchor expression statement] - (-> (///generation.Phase anchor expression statement) + (-> (////generation.Phase anchor expression statement) Name Type Synthesis (Operation anchor expression statement [Type expression Text Any]))) - (////statement.lift-generation - (do ///.monad + (/////statement.lift-generation + (do ////.monad [codeT (generate codeS) - [target-name value statement] (///generation.define! name codeT) - _ (///generation.save! false name statement)] + [target-name value statement] (////generation.define! name codeT) + _ (////generation.save! false name statement)] (wrap [code//type codeT target-name value])))) (def: (definition name expected codeC) (All [anchor expression statement] (-> Name (Maybe Type) Code (Operation anchor expression statement [Type expression Text Any]))) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#////statement.analysis #////statement.phase] state) - synthesize (get@ [#////statement.synthesis #////statement.phase] state) - generate (get@ [#////statement.generation #////statement.phase] state)] - [_ code//type codeA] (////statement.lift-analysis - (////analysis.with-scope + (do ////.monad + [state (///.lift ////.get-state) + #let [analyse (get@ [#/////statement.analysis #/////statement.phase] state) + synthesize (get@ [#/////statement.synthesis #/////statement.phase] state) + generate (get@ [#/////statement.generation #/////statement.phase] state)] + [_ code//type codeA] (/////statement.lift-analysis + (/////analysis.with-scope (typeA.with-fresh-env (case expected #.None @@ -107,86 +123,70 @@ [codeA (typeA.with-type expected (analyse codeC))] (wrap [expected codeA])))))) - codeS (////statement.lift-synthesis + codeS (/////statement.lift-synthesis (synthesize codeA))] (definition' generate name code//type codeS))) (def: (refresh expander) (All [anchor expression statement] (-> Expander (Operation anchor expression statement Any))) - (do ///.monad - [[bundle state] ///.get-state - #let [eval (////evaluation.evaluator expander - (get@ [#////statement.synthesis #////statement.state] state) - (get@ [#////statement.generation #////statement.state] state) - (get@ [#////statement.generation #////statement.phase] state))]] - (///.set-state [bundle - (update@ [#////statement.analysis #////statement.state] - (: (-> ////analysis.State+ ////analysis.State+) - (|>> product.right - [(//analysis.bundle eval)])) - state)]))) + (do ////.monad + [[bundle state] ////.get-state + #let [eval (/////evaluation.evaluator expander + (get@ [#/////statement.synthesis #/////statement.state] state) + (get@ [#/////statement.generation #/////statement.state] state) + (get@ [#/////statement.generation #/////statement.phase] state))]] + (////.set-state [bundle + (update@ [#/////statement.analysis #/////statement.state] + (: (-> /////analysis.State+ /////analysis.State+) + (|>> product.right + [(///analysis.bundle eval)])) + state)]))) (def: (lux::def expander) (-> Expander Handler) (function (_ extension-name phase inputsC+) (case inputsC+ (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC [_ (#.Bit exported?)])) - (do ///.monad - [current-module (////statement.lift-analysis - (//.lift macro.current-module-name)) + (do ////.monad + [current-module (/////statement.lift-analysis + (///.lift macro.current-module-name)) #let [full-name [current-module short-name]] [_ annotationsT annotations] (evaluate! Code annotationsC) #let [annotations (:coerce Code annotations)] [type valueT valueN value] (..definition full-name #.None valueC) - _ (////statement.lift-analysis + _ (/////statement.lift-analysis (module.define short-name (#.Right [exported? type annotations value]))) #let [_ (log! (format "Definition " (%name full-name)))] - _ (////statement.lift-generation - (///generation.learn full-name valueN)) + _ (/////statement.lift-generation + (////generation.learn full-name valueN)) _ (..refresh expander)] - (wrap ////statement.no-requirements)) + (wrap /////statement.no-requirements)) _ - (///.throw //.invalid-syntax [extension-name %code inputsC+])))) - -(def: (custom [syntax handler]) - (All [anchor expression statement s] - (-> [(Parser s) - (-> Text - (Phase anchor expression statement) - s - (Operation anchor expression statement Requirements))] - (Handler anchor expression statement))) - (function (_ extension-name phase inputs) - (case (s.run syntax inputs) - (#error.Success inputs) - (handler extension-name phase inputs) - - (#error.Failure error) - (///.throw //.invalid-syntax [extension-name %code inputs])))) + (////.throw ///.invalid-syntax [extension-name %code inputsC+])))) (def: (def::type-tagged expander) (-> Expander Handler) (..custom [($_ p.and s.local-identifier s.any s.any (s.tuple (p.some s.text)) s.bit) (function (_ extension-name phase [short-name valueC annotationsC tags exported?]) - (do ///.monad - [current-module (////statement.lift-analysis - (//.lift macro.current-module-name)) + (do ////.monad + [current-module (/////statement.lift-analysis + (///.lift macro.current-module-name)) #let [full-name [current-module short-name]] [_ annotationsT annotations] (evaluate! Code annotationsC) #let [annotations (:coerce Code annotations)] [type valueT valueN value] (..definition full-name (#.Some .Type) valueC) - _ (////statement.lift-analysis - (do ///.monad + _ (/////statement.lift-analysis + (do ////.monad [_ (module.define short-name (#.Right [exported? type annotations value]))] (module.declare-tags tags exported? (:coerce Type value)))) #let [_ (log! (format "Definition " (%name full-name)))] - _ (////statement.lift-generation - (///generation.learn full-name valueN)) + _ (/////statement.lift-generation + (////generation.learn full-name valueN)) _ (..refresh expander)] - (wrap ////statement.no-requirements)))])) + (wrap /////statement.no-requirements)))])) (def: imports (Parser (List Import)) @@ -199,10 +199,10 @@ (..custom [($_ p.and s.any ..imports) (function (_ extension-name phase [annotationsC imports]) - (do ///.monad + (do ////.monad [[_ annotationsT annotationsV] (evaluate! Code annotationsC) #let [annotationsV (:coerce Code annotationsV)] - _ (////statement.lift-analysis + _ (/////statement.lift-analysis (do @ [_ (monad.map @ (function (_ [module alias]) (do @ @@ -212,8 +212,8 @@ _ (module.alias alias module)))) imports)] (module.set-annotations annotationsV)))] - (wrap {#////statement.imports imports - #////statement.referrals (list)})))])) + (wrap {#/////statement.imports imports + #/////statement.referrals (list)})))])) (exception: #export (cannot-alias-an-alias {local Alias} {foreign Alias} {target Name}) (exception.report @@ -222,13 +222,13 @@ ["Target definition" (%name target)])) (def: (define-alias alias original) - (-> Text Name (////analysis.Operation Any)) - (do ///.monad - [current-module (//.lift macro.current-module-name) - constant (//.lift (macro.find-def original))] + (-> Text Name (/////analysis.Operation Any)) + (do ////.monad + [current-module (///.lift macro.current-module-name) + constant (///.lift (macro.find-def original))] (case constant (#.Left de-aliased) - (///.throw ..cannot-alias-an-alias [[current-module alias] original de-aliased]) + (////.throw ..cannot-alias-an-alias [[current-module alias] original de-aliased]) (#.Right [exported? original-type original-annotations original-value]) (module.define alias (#.Left original))))) @@ -238,12 +238,12 @@ (..custom [($_ p.and s.local-identifier s.identifier) (function (_ extension-name phase [alias def-name]) - (do ///.monad - [_ (//.lift - (///.sub [(get@ [#////statement.analysis #////statement.state]) - (set@ [#////statement.analysis #////statement.state])] - (define-alias alias def-name)))] - (wrap ////statement.no-requirements)))])) + (do ////.monad + [_ (///.lift + (////.sub [(get@ [#/////statement.analysis #/////statement.state]) + (set@ [#/////statement.analysis #/////statement.state])] + (define-alias alias def-name)))] + (wrap /////statement.no-requirements)))])) (template [<mame> <type> <scope>] [(def: <mame> @@ -252,28 +252,28 @@ (function (handler extension-name phase inputsC+) (case inputsC+ (^ (list [_ (#.Text name)] valueC)) - (do ///.monad + (do ////.monad [[_ handlerT handlerV] (evaluate! (:by-example [anchor expression statement] {(Handler anchor expression statement) handler} <type>) valueC) _ (<| <scope> - (//.install name) + (///.install name) (:share [anchor expression statement] {(Handler anchor expression statement) handler} {<type> (:assume handlerV)}))] - (wrap ////statement.no-requirements)) + (wrap /////statement.no-requirements)) _ - (///.throw //.invalid-syntax [extension-name %code inputsC+]))))] + (////.throw ///.invalid-syntax [extension-name %code inputsC+]))))] - [def::analysis ////analysis.Handler ////statement.lift-analysis] - [def::synthesis ////synthesis.Handler ////statement.lift-synthesis] - [def::generation (///generation.Handler anchor expression statement) ////statement.lift-generation] - [def::statement (////statement.Handler anchor expression statement) (<|)] + [def::analysis /////analysis.Handler /////statement.lift-analysis] + [def::synthesis /////synthesis.Handler /////statement.lift-synthesis] + [def::generation (////generation.Handler anchor expression statement) /////statement.lift-generation] + [def::statement (/////statement.Handler anchor expression statement) (<|)] ) ## TODO; Both "prepare-program" and "define-program" exist only @@ -281,28 +281,28 @@ ## for "def::program". Inline them ASAP. (def: (prepare-program analyse synthesize programC) (All [anchor expression statement output] - (-> ////analysis.Phase - ////synthesis.Phase + (-> /////analysis.Phase + /////synthesis.Phase Code (Operation anchor expression statement Synthesis))) - (do ///.monad - [[_ programA] (////statement.lift-analysis - (////analysis.with-scope + (do ////.monad + [[_ programA] (/////statement.lift-analysis + (/////analysis.with-scope (typeA.with-fresh-env (typeA.with-type (type (-> (List Text) (IO Any))) (analyse programC)))))] - (////statement.lift-synthesis + (/////statement.lift-synthesis (synthesize programA)))) (def: (define-program generate program programS) (All [anchor expression statement output] - (-> (///generation.Phase anchor expression statement) + (-> (////generation.Phase anchor expression statement) (-> expression statement) Synthesis - (///generation.Operation anchor expression statement Any))) - (do ///.monad + (////generation.Operation anchor expression statement Any))) + (do ////.monad [programG (generate programS)] - (///generation.save! false ["" ""] (program programG)))) + (////generation.save! false ["" ""] (program programG)))) (def: (def::program program) (All [anchor expression statement] @@ -310,24 +310,24 @@ (function (handler extension-name phase inputsC+) (case inputsC+ (^ (list programC)) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#////statement.analysis #////statement.phase] state) - synthesize (get@ [#////statement.synthesis #////statement.phase] state) - generate (get@ [#////statement.generation #////statement.phase] state)] + (do ////.monad + [state (///.lift ////.get-state) + #let [analyse (get@ [#/////statement.analysis #/////statement.phase] state) + synthesize (get@ [#/////statement.synthesis #/////statement.phase] state) + generate (get@ [#/////statement.generation #/////statement.phase] state)] programS (prepare-program analyse synthesize programC) - _ (////statement.lift-generation + _ (/////statement.lift-generation (define-program generate program programS))] - (wrap ////statement.no-requirements)) + (wrap /////statement.no-requirements)) _ - (///.throw //.invalid-syntax [extension-name %code inputsC+])))) + (////.throw ///.invalid-syntax [extension-name %code inputsC+])))) (def: (bundle::def expander program) (All [anchor expression statement] (-> Expander (-> expression statement) (Bundle anchor expression statement))) - (<| (//bundle.prefix "def") - (|> //bundle.empty + (<| (///bundle.prefix "def") + (|> ///bundle.empty (dictionary.put "module" def::module) (dictionary.put "alias" def::alias) (dictionary.put "type tagged" (def::type-tagged expander)) @@ -341,7 +341,7 @@ (def: #export (bundle expander program) (All [anchor expression statement] (-> Expander (-> expression statement) (Bundle anchor expression statement))) - (<| (//bundle.prefix "lux") - (|> //bundle.empty + (<| (///bundle.prefix "lux") + (|> ///bundle.empty (dictionary.put "def" (lux::def expander)) (dictionary.merge (..bundle::def expander program))))) |