diff options
Diffstat (limited to 'stdlib/source/lux/compiler/default/phase/extension')
3 files changed, 118 insertions, 102 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis.lux index 4d78ceb43..cc4736ac0 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/analysis.lux @@ -4,12 +4,14 @@ [collection ["." dictionary]]]] [/// - [analysis (#+ Bundle)]] + [analysis (#+ Bundle)] + [// + [evaluation (#+ Eval)]]] [/ ["." common] ["." host]]) -(def: #export bundle - Bundle +(def: #export (bundle eval) + (-> Eval Bundle) (dictionary.merge host.bundle - common.bundle)) + (common.bundle eval))) diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux index bf8e73b86..0d1148fbd 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux @@ -1,8 +1,7 @@ (.module: [lux #* [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] + ["." monad (#+ do)]] [data ["." text format] @@ -12,13 +11,15 @@ [type ["." check]] [io (#+ IO)]] - ["." //// - ["." analysis (#+ Analysis Handler Bundle) - [".A" type] - [".A" case] - [".A" function]]] ["." /// - ["." bundle]]) + ["." bundle] + ["//." // + ["." analysis (#+ Analysis Handler Bundle) + [".A" type] + [".A" case] + [".A" function]] + [// + [evaluation (#+ Eval)]]]]) ## [Utils] (def: (simple inputsT+ outputT) @@ -91,24 +92,25 @@ _ (////.throw bundle.invalid-syntax [extension-name])))) -## (do-template [<name> <type>] -## [(def: <name> -## Handler -## (function (_ extension-name analyse args) -## (case args -## (^ (list typeC valueC)) -## (do ////.Monad<Operation> -## [actualT (eval Type typeC) -## _ (typeA.infer (:coerce Type actualT))] -## (typeA.with-type <type> -## (analyse valueC))) - -## _ -## (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)]))))] - -## [lux::check (:coerce Type actualT)] -## [lux::coerce Any] -## ) +(do-template [<name> <type>] + [(def: (<name> eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.Monad<Operation> + [actualT (:: @ map (|>> (:coerce Type)) + (eval Type typeC)) + _ (typeA.infer actualT)] + (typeA.with-type <type> + (analyse valueC))) + + _ + (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)]))))] + + [lux::check actualT] + [lux::coerce Any] + ) (def: lux::check::type Handler @@ -124,13 +126,13 @@ _ (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)])))) -(def: bundle::lux - Bundle +(def: (bundle::lux eval) + (-> Eval Bundle) (|> bundle.empty (bundle.install "is" lux::is) (bundle.install "try" lux::try) - ## (bundle.install "check" lux::check) - ## (bundle.install "coerce" lux::coerce) + (bundle.install "check" (lux::check eval)) + (bundle.install "coerce" (lux::coerce eval)) (bundle.install "check type" lux::check::type) (bundle.install "in-module" lux::in-module))) @@ -201,11 +203,11 @@ (bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) ))) -(def: #export bundle - Bundle +(def: #export (bundle eval) + (-> Eval Bundle) (<| (bundle.prefix "lux") (|> bundle.empty - (dict.merge bundle::lux) + (dict.merge (bundle::lux eval)) (dict.merge bundle::bit) (dict.merge bundle::int) (dict.merge bundle::frac) diff --git a/stdlib/source/lux/compiler/default/phase/extension/statement.lux b/stdlib/source/lux/compiler/default/phase/extension/statement.lux index b1b28b6a3..7daf27227 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/statement.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/statement.lux @@ -4,35 +4,57 @@ [monad (#+ do)] pipe] [data + [text + format] [collection [list ("list/." Functor<List>)] ["." dictionary]]] ["." macro] [type (#+ :share) ["." check]]] - [// - ["/." // (#+ Eval) - ["." analysis - ["." module] - ["." type]] - ["." synthesis] - ["." translation] - ["." statement (#+ Operation Handler Bundle)] - ["." extension - ["." bundle]] - [// - ["." evaluation]]]]) - -(def: (compile ?name ?type codeC) + ["." /// + ["." analysis + ["." module] + ["." type]] + ["." synthesis] + ["." translation] + ["." statement (#+ Operation Handler Bundle)] + ["." extension + ["." bundle]]]) + +(def: (evaluate! type codeC) (All [anchor expression statement] - (-> (Maybe Name) (Maybe Type) Code - (Operation anchor expression statement [Type expression Any]))) + (-> Type Code (Operation anchor expression statement [Type expression Any]))) (do ///.Monad<Operation> [state (extension.lift ///.state) #let [analyse (get@ [#statement.analysis #statement.phase] state) synthesize (get@ [#statement.synthesis #statement.phase] state) translate (get@ [#statement.translation #statement.phase] state)] - [_ code//type codeA] (statement.lift-analysis! + [_ code//type codeA] (statement.lift-analysis + (analysis.with-scope + (type.with-fresh-env + (type.with-type type + (do @ + [codeA (analyse codeC)] + (wrap [type codeA])))))) + codeS (statement.lift-synthesis + (synthesize codeA))] + (statement.lift-translation + (do @ + [codeT (translate codeS) + codeV (translation.evaluate! codeT)] + (wrap [code//type codeT codeV]))))) + +(def: (define! name ?type codeC) + (All [anchor expression statement] + (-> Name (Maybe Type) Code + (Operation anchor expression statement [Type expression Text Any]))) + (do ///.Monad<Operation> + [state (extension.lift ///.state) + #let [analyse (get@ [#statement.analysis #statement.phase] state) + synthesize (get@ [#statement.synthesis #statement.phase] state) + translate (get@ [#statement.translation #statement.phase] state)] + [_ code//type codeA] (statement.lift-analysis (analysis.with-scope (type.with-fresh-env (case ?type @@ -48,18 +70,13 @@ code//type (type.with-env (check.clean code//type))] (wrap [code//type codeA])))))) - codeS (statement.lift-synthesis! + codeS (statement.lift-synthesis (synthesize codeA))] - (statement.lift-translation! + (statement.lift-translation (do @ [codeT (translate codeS) - codeV (case ?name - (#.Some name) - (translation.define! name codeT) - - #.None - (translation.evaluate! codeT))] - (wrap [code//type codeT codeV]))))) + codeN+V (translation.define! name codeT)] + (wrap [code//type codeT codeN+V]))))) (def: lux::def Handler @@ -67,27 +84,31 @@ (case inputsC+ (^ (list [_ (#.Identifier ["" def-name])] valueC annotationsC)) (do ///.Monad<Operation> - [[_ annotationsT annotationsV] (compile #.None (#.Some Code) annotationsC) + [[_ annotationsT annotationsV] (evaluate! Code annotationsC) #let [annotationsV (:coerce Code annotationsV)] - current-module (statement.lift-analysis! + current-module (statement.lift-analysis (extension.lift macro.current-module-name)) - [value//type valueT valueV] (compile (#.Some [current-module def-name]) - (if (macro.type? annotationsV) - (#.Some Type) - #.None) - valueC)] - (statement.lift-analysis! - (do @ - [_ (module.define def-name [value//type annotationsV valueV])] - (if (macro.type? annotationsV) - (case (macro.declared-tags annotationsV) - #.Nil - (wrap []) - - tags - (module.declare-tags tags (macro.export? annotationsV) (:coerce Type valueV))) - (wrap []))))) + #let [full-name [current-module def-name]] + [value//type valueT valueN valueV] (define! full-name + (if (macro.type? annotationsV) + (#.Some Type) + #.None) + valueC) + _ (statement.lift-analysis + (do @ + [_ (module.define def-name [value//type annotationsV valueV]) + #let [_ (log! (format "Definition " (%name full-name)))]] + (if (macro.type? annotationsV) + (case (macro.declared-tags annotationsV) + #.Nil + (wrap []) + + tags + (module.declare-tags tags (macro.export? annotationsV) (:coerce Type valueV))) + (wrap []))))] + (statement.lift-translation + (translation.learn full-name valueN))) _ (///.throw bundle.invalid-syntax [extension-name])))) @@ -104,8 +125,8 @@ (case inputsC+ (^ (list annotationsC)) (do ///.Monad<Operation> - [[_ annotationsT annotationsV] (compile #.None (#.Some Code) annotationsC) - _ (statement.lift-analysis! + [[_ annotationsT annotationsV] (evaluate! Code annotationsC) + _ (statement.lift-analysis (module.set-annotations (:coerce Code annotationsV)))] (wrap [])) @@ -133,13 +154,12 @@ (case inputsC+ (^ (list [_ (#.Text name)] valueC)) (do ///.Monad<Operation> - [[_ handlerT handlerV] (compile #.None - (#.Some (:of (:share [anchor expression statement] - {(Handler anchor expression statement) - handler} - {<type> - (:assume [])}))) - valueC)] + [[_ handlerT handlerV] (evaluate! (:of (:share [anchor expression statement] + {(Handler anchor expression statement) + handler} + {<type> + (:assume [])})) + valueC)] (<| <scope> (extension.install name) (:share [anchor expression statement] @@ -151,18 +171,10 @@ _ (///.throw bundle.invalid-syntax [extension-name]))))] - [def::analysis analysis.Handler statement.lift-analysis!] - [def::synthesis synthesis.Handler - (<| extension.lift - (///.sub [(get@ [#statement.synthesis #statement.state]) - (set@ [#statement.synthesis #statement.state])]))] - [def::translation (translation.Handler anchor expression statement) - (<| extension.lift - (///.sub [(get@ [#statement.translation #statement.state]) - (set@ [#statement.translation #statement.state])]))] - - [def::statement (Handler anchor expression statement) - (<|)] + [def::analysis analysis.Handler statement.lift-analysis] + [def::synthesis synthesis.Handler statement.lift-synthesis] + [def::translation (translation.Handler anchor expression statement) statement.lift-translation] + [def::statement (statement.Handler anchor expression statement) (<|)] ) (def: bundle::def |