diff options
16 files changed, 368 insertions, 258 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index dafd7d68c..14f8cf0a0 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -12,6 +12,7 @@ format] [collection ["." array] + [list ("list/." Functor<List>)] ["." dictionary (#+ Dictionary)]]] ["." host (#+ import: do-to object)] ["." io (#+ IO io)] @@ -83,17 +84,14 @@ (type: Store (Atom (Dictionary Text ByteCode))) -(def: (fetch-bytecode class-name store) - (-> Text Store (Maybe ByteCode)) - (|> store atom.read io.run (dictionary.get class-name))) - -(do-template [<name>] - [(exception: #export (<name> {class Text}) - (ex.report ["Class" class]))] +(exception: #export (class-already-stored {class Text}) + (ex.report ["Class" class])) - [unknown-class] - [class-already-stored] - ) +(exception: #export (unknown-class {class Text} {known-classes (List Text)}) + (ex.report ["Class" class] + ["Known Classes" (|> known-classes + (list/map (|>> (format "\n\t"))) + (text.join-with ""))])) (exception: #export (cannot-define-class {class Text} {error Text}) (ex.report ["Class" class] @@ -104,17 +102,18 @@ (object [] ClassLoader [] [] (ClassLoader (findClass {class-name String}) Class - (case (fetch-bytecode class-name store) - (#.Some bytecode) - (case (define-class class-name bytecode (:coerce ClassLoader _jvm_this)) - (#error.Success class) - (:assume class) + (let [classes (|> store atom.read io.run)] + (case (dictionary.get class-name classes) + (#.Some bytecode) + (case (define-class class-name bytecode (:coerce ClassLoader _jvm_this)) + (#error.Success class) + (:assume class) - (#error.Error error) - (error! (ex.construct cannot-define-class [class-name error]))) + (#error.Error error) + (error! (ex.construct cannot-define-class [class-name error]))) - #.None - (error! (ex.construct unknown-class class-name)))))) + #.None + (error! (ex.construct unknown-class [class-name (dictionary.keys classes)]))))))) (def: (store! name bytecode store) (-> Text ByteCode Store (Error Any)) @@ -191,11 +190,13 @@ (..load! class-name loader))) (def: (define! store loader [module name] valueI) - (-> Store ClassLoader Name Inst (Error Any)) + (-> Store ClassLoader Name Inst (Error [Text Any])) (let [class-name (format (text.replace-all module-separator class-path-separator module) class-path-separator (name.normalize name) "___" (%n (text/hash name)))] - (evaluate! store loader class-name valueI))) + (do error.Monad<Error> + [value (evaluate! store loader class-name valueI)] + (wrap [class-name value])))) (def: #export init (IO Host) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 793cf5a4d..7faad6c0a 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -21,7 +21,7 @@ (1 [[dummy-cursor (7 ["lux" "doc"])] [dummy-cursor (5 "The type of things whose type does not matter. - It can be used to write functions or data-structures that can take, or return, anything.")]] + It can be used to write functions or data-structures that can take, or return, anything.")]] (0)))))]) ## (type: Nothing @@ -37,7 +37,7 @@ (1 [[dummy-cursor (7 ["lux" "doc"])] [dummy-cursor (5 "The type of things whose type is unknown or undefined. - Useful for expressions that cause errors or other \"extraordinary\" conditions.")]] + Useful for expressions that cause errors or other \"extraordinary\" conditions.")]] (0)))))]) ## (type: (List a) @@ -100,7 +100,7 @@ (#Cons [[dummy-cursor (7 ["lux" "doc"])] [dummy-cursor (5 "Natural numbers (unsigned integers). - They start at zero (0) and extend in the positive direction.")]] + They start at zero (0) and extend in the positive direction.")]] #Nil))))]) ("lux def" Int @@ -126,7 +126,7 @@ (#Cons [[dummy-cursor (7 ["lux" "doc"])] [dummy-cursor (5 "Fractional numbers that live in the interval [0,1). - Useful for probability, and other domains that work within that interval.")]] + Useful for probability, and other domains that work within that interval.")]] #Nil))))]) ("lux def" Frac @@ -164,7 +164,7 @@ (#Cons [[dummy-cursor (7 ["lux" "doc"])] [dummy-cursor (5 "A name. - It is used as part of Lux syntax to represent identifiers and tags.")]] + It is used as part of Lux syntax to represent identifiers and tags.")]] #Nil))))]) ## (type: (Maybe a) diff --git a/stdlib/source/lux/compiler/default.lux b/stdlib/source/lux/compiler/default.lux index e53e08142..190eee760 100644 --- a/stdlib/source/lux/compiler/default.lux +++ b/stdlib/source/lux/compiler/default.lux @@ -85,7 +85,7 @@ (def: (begin-module-compilation module-name source) (All [anchor expression statement] (-> Text Source <Operation>)) - (statement.lift-analysis! + (statement.lift-analysis (do phase.Monad<Operation> [_ (module.create (text/hash (get@ #code source)) module-name) _ (analysis.set-current-module module-name)] @@ -95,7 +95,7 @@ (All [anchor expression statement] (-> Text <Operation>)) (|>> module.set-compiled - statement.lift-analysis!)) + statement.lift-analysis)) (def: (loop-module-compilation module-name) (All [anchor expression statement] @@ -103,7 +103,7 @@ (forgive-eof (loop [_ []] (do phase.Monad<Operation> - [code (statement.lift-analysis! + [code (statement.lift-analysis (do @ [code (..read module-name syntax.no-aliases) #let [[cursor _] code] @@ -144,7 +144,7 @@ (-> <Platform> Configuration (fs <Compiler>))) (|> platform (get@ #runtime) - statement.lift-translation! + statement.lift-translation (phase.run' (init.state (get@ #host platform) (get@ #phase platform))) (:: error.Functor<Error> map product.left) diff --git a/stdlib/source/lux/compiler/default/evaluation.lux b/stdlib/source/lux/compiler/default/evaluation.lux index 3e00d79c5..d93feca93 100644 --- a/stdlib/source/lux/compiler/default/evaluation.lux +++ b/stdlib/source/lux/compiler/default/evaluation.lux @@ -1,30 +1,34 @@ (.module: [lux #* [control - [monad (#+ do)] - pipe] + [monad (#+ do)]] [data ["." error]]] [// - ["." phase (#+ Eval) - ["." analysis - [".A" expression]] + ["." phase + [analysis (#+ Operation) + [".A" expression] + ["." type]] ["." synthesis [".S" expression]] ["." translation]]]) -(def: #export (evaluator analysis-state synthesis-state translation-state translate) +(type: #export Eval + (-> Type Code (Operation Any))) + +(def: #export (evaluator synthesis-state translation-state translate) (All [anchor expression statement] - (-> analysis.State+ - synthesis.State+ + (-> synthesis.State+ (translation.State+ anchor expression statement) (translation.Phase anchor expression statement) Eval)) (function (eval type exprC) - (do error.Monad<Error> - [exprA (|> exprC (expressionA.analyser eval)(phase.run analysis-state)) - exprS (|> exprA expressionS.synthesize (phase.run synthesis-state))] - (phase.run translation-state - (do phase.Monad<Operation> - [exprO (translate exprS)] - (translation.evaluate! exprO)))))) + (do phase.Monad<Operation> + [exprA (type.with-type type + (expressionA.compile exprC))] + (phase.lift (do error.Monad<Error> + [exprS (|> exprA expressionS.synthesize (phase.run synthesis-state))] + (phase.run translation-state + (do phase.Monad<Operation> + [exprO (translate exprS)] + (translation.evaluate! exprO)))))))) diff --git a/stdlib/source/lux/compiler/default/init.lux b/stdlib/source/lux/compiler/default/init.lux index 4bd2f807d..e30f5c551 100644 --- a/stdlib/source/lux/compiler/default/init.lux +++ b/stdlib/source/lux/compiler/default/init.lux @@ -2,7 +2,7 @@ lux [// ["." evaluation] - [phase (#+ Eval) + [phase [analysis [".A" expression]] ["." synthesis @@ -73,13 +73,13 @@ (-> (Host expression statement) (translation.Phase anchor expression statement) (statement.State+ anchor expression statement))) - (let [analysis-state [analysisE.bundle (..compiler host)] - synthesis-state [synthesisE.bundle synthesis.init] + (let [synthesis-state [synthesisE.bundle synthesis.init] translation-state [translationE.bundle (translation.state host)] - eval (evaluation.evaluator analysis-state synthesis-state translation-state translate)] + eval (evaluation.evaluator synthesis-state translation-state translate) + analysis-state [(analysisE.bundle eval) (..compiler host)]] [statementE.bundle {#statement.analysis {#statement.state analysis-state - #statement.phase (expressionA.analyser eval)} + #statement.phase expressionA.compile} #statement.synthesis {#statement.state synthesis-state #statement.phase expressionS.synthesize} #statement.translation {#statement.state translation-state diff --git a/stdlib/source/lux/compiler/default/phase.lux b/stdlib/source/lux/compiler/default/phase.lux index 85567e45c..920d81996 100644 --- a/stdlib/source/lux/compiler/default/phase.lux +++ b/stdlib/source/lux/compiler/default/phase.lux @@ -6,7 +6,7 @@ [monad (#+ do)]] [data ["." product] - ["." error (#+ Error)] + ["." error (#+ Error) ("error/." Functor<Error>)] ["." text format]] [macro @@ -58,6 +58,11 @@ (state.lift error.Monad<Error> (ex.throw exception parameters))) +(def: #export (lift error) + (All [s a] (-> (Error a) (Operation s a))) + (function (_ state) + (error/map (|>> [state]) error))) + (syntax: #export (assert exception message test) (wrap (list (` (if (~ test) (:: ..Monad<Operation> (~' wrap) []) @@ -83,6 +88,3 @@ [[pre/state' temp] (pre input pre/state) [post/state' output] (post temp post/state)] (wrap [[pre/state' post/state'] output])))) - -(type: #export Eval - (-> Type Code (Error Any))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux index 974fc2473..578560d11 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis.lux @@ -3,9 +3,11 @@ [data ["." product] ["." error] - [text ("text/." Equivalence<Text>)] + ["." maybe] + ["." text ("text/." Equivalence<Text>) + format] [collection - ["." list ("list/." Fold<List>)]]] + ["." list ("list/." Functor<List> Fold<List>)]]] ["." function]] [// ["." extension (#+ Extension)] @@ -128,7 +130,7 @@ value) (list.indices (inc tag))))))] - [sum-analysis Analysis #Structure no-op] + [sum-analysis Analysis #Structure ..no-op] [sum-pattern Pattern #Complex id] ) @@ -290,3 +292,69 @@ [set-current-module Text #.current-module (#.Some value)] [set-cursor Cursor #.cursor value] ) + +(def: #export (%analysis analysis) + (Format Analysis) + (case analysis + (#Primitive primitive) + (case primitive + #Unit + "[]" + + (^template [<tag> <format>] + (<tag> value) + (<format> value)) + ([#Bit %b] + [#Nat %n] + [#Int %i] + [#Rev %r] + [#Frac %f] + [#Text %t])) + + (#Structure structure) + (case structure + (#Sum _) + (let [[lefts right? value] (maybe.assume (..variant analysis))] + (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")")) + + (#Product _) + (|> analysis + ..tuple + (list/map %analysis) + (text.join-with " ") + (text.enclose ["[" "]"]))) + + (#Reference reference) + (case reference + (#reference.Variable variable) + (reference.%variable variable) + + (#reference.Constant constant) + (%name constant)) + + (#Case analysis match) + "{?}" + + (#Function environment body) + (|> (%analysis body) + (format " ") + (format (|> environment + (list/map reference.%variable) + (text.join-with " ") + (text.enclose ["[" "]"]))) + (text.enclose ["(" ")"])) + + (#Apply _) + (|> analysis + ..application + #.Cons + (list/map %analysis) + (text.join-with " ") + (text.enclose ["(" ")"])) + + (#Extension name parameters) + (|> parameters + (list/map %analysis) + (text.join-with " ") + (format (%t name) " ") + (text.enclose ["(" ")"])))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux index 6b0d38a53..e46576201 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux @@ -13,7 +13,8 @@ ["." primitive] ["." structure] ["." reference] - ["/." // (#+ Eval) + ["." case] + ["/." // ["." extension] [// ## [".L" macro] @@ -30,92 +31,94 @@ [unrecognized-syntax] ) -(def: #export (analyser eval) - (-> Eval Phase) - (function (compile code) - (do ///.Monad<Operation> - [expectedT (extension.lift macro.expected-type)] - (let [[cursor code'] code] - ## The cursor must be set in the state for the sake - ## of having useful error messages. - (//.with-cursor cursor - (case code' - (^template [<tag> <analyser>] - (<tag> value) - (<analyser> value)) - ([#.Bit primitive.bit] - [#.Nat primitive.nat] - [#.Int primitive.int] - [#.Rev primitive.rev] - [#.Frac primitive.frac] - [#.Text primitive.text]) - - (^template [<tag> <analyser>] - (^ (#.Form (list& [_ (<tag> tag)] - values))) - (case values - (#.Cons value #.Nil) - (<analyser> compile tag value) - - _ - (<analyser> compile tag (` [(~+ values)])))) - ([#.Nat structure.sum] - [#.Tag structure.tagged-sum]) - - (#.Tag tag) - (structure.tagged-sum compile tag (' [])) - - (^ (#.Tuple (list))) - primitive.unit - - (^ (#.Tuple (list singleton))) - (compile singleton) - - (^ (#.Tuple elems)) - (structure.product compile elems) - - (^ (#.Record pairs)) - (structure.record compile pairs) - - (#.Identifier reference) - (reference.reference reference) - - (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) - (extension.apply compile [extension-name extension-args]) - - ## (^ (#.Form (list& func args))) - ## (do ///.Monad<Operation> - ## [[funcT funcA] (type.with-inference - ## (compile func))] - ## (case funcA - ## [_ (#.Identifier def-name)] - ## (do @ - ## [?macro (///.with-error-tracking - ## (extension.lift (macro.find-macro def-name)))] - ## (case ?macro - ## (#.Some macro) - ## (do @ - ## [expansion (: (Operation (List Code)) - ## (function (_ state) - ## (case (macroL.expand macro args state) - ## (#e.Error error) - ## ((///.throw macro-expansion-failed error) state) - - ## output - ## output)))] - ## (case expansion - ## (^ (list single)) - ## (compile single) - - ## _ - ## (///.throw macro-call-must-have-single-expansion code))) - - ## _ - ## (functionA.apply compile funcT funcA args))) - - ## _ - ## (functionA.apply compile funcT funcA args))) - - _ - (///.throw unrecognized-syntax code) - )))))) +(def: #export (compile code) + Phase + (do ///.Monad<Operation> + [expectedT (extension.lift macro.expected-type)] + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (//.with-cursor cursor + (case code' + (^template [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#.Bit primitive.bit] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) + + (^template [<tag> <analyser>] + (^ (#.Form (list& [_ (<tag> tag)] + values))) + (case values + (#.Cons value #.Nil) + (<analyser> compile tag value) + + _ + (<analyser> compile tag (` [(~+ values)])))) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) + + (#.Tag tag) + (structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (structure.product compile elems) + + (^ (#.Record pairs)) + (structure.record compile pairs) + + (#.Identifier reference) + (reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (case.case compile input branches) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (extension.apply compile [extension-name extension-args]) + + ## (^ (#.Form (list& func args))) + ## (do ///.Monad<Operation> + ## [[funcT funcA] (type.with-inference + ## (compile func))] + ## (case funcA + ## [_ (#.Identifier def-name)] + ## (do @ + ## [?macro (///.with-error-tracking + ## (extension.lift (macro.find-macro def-name)))] + ## (case ?macro + ## (#.Some macro) + ## (do @ + ## [expansion (: (Operation (List Code)) + ## (function (_ state) + ## (case (macroL.expand macro args state) + ## (#e.Error error) + ## ((///.throw macro-expansion-failed error) state) + + ## output + ## output)))] + ## (case expansion + ## (^ (list single)) + ## (compile single) + + ## _ + ## (///.throw macro-call-must-have-single-expansion code))) + + ## _ + ## (functionA.apply compile funcT funcA args))) + + ## _ + ## (functionA.apply compile funcT funcA args))) + + _ + (///.throw unrecognized-syntax code) + ))))) 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 diff --git a/stdlib/source/lux/compiler/default/phase/statement.lux b/stdlib/source/lux/compiler/default/phase/statement.lux index daaea020c..c7ff3719f 100644 --- a/stdlib/source/lux/compiler/default/phase/statement.lux +++ b/stdlib/source/lux/compiler/default/phase/statement.lux @@ -39,7 +39,7 @@ (set@ [<component> #..state])] operation)))] - [lift-analysis! #..analysis analysis.Operation] - [lift-synthesis! #..synthesis synthesis.Operation] - [lift-translation! #..translation (translation.Operation anchor expression statement)] + [lift-analysis #..analysis analysis.Operation] + [lift-synthesis #..synthesis synthesis.Operation] + [lift-translation #..translation (translation.Operation anchor expression statement)] ) diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux b/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux index 241896e58..4a5f2979c 100644 --- a/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux +++ b/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux @@ -82,6 +82,9 @@ (#analysis.Case inputA branchesAB+) (case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+) + (^ (analysis.no-op value)) + (synthesize value) + (#analysis.Apply _) (function.apply (|>> synthesize //.indirectly) analysis) diff --git a/stdlib/source/lux/compiler/default/phase/translation.lux b/stdlib/source/lux/compiler/default/phase/translation.lux index 3bf09937f..3cca0c060 100644 --- a/stdlib/source/lux/compiler/default/phase/translation.lux +++ b/stdlib/source/lux/compiler/default/phase/translation.lux @@ -57,7 +57,7 @@ evaluate!) (: (-> Text statement (Error Any)) execute!) - (: (-> Name expression (Error Any)) + (: (-> Name expression (Error [Text Any])) define!)) (type: #export (Buffer statement) (Row [Name statement])) @@ -180,13 +180,14 @@ [(def: #export (<name> code) (All [anchor expression statement] (-> <inputT> (Operation anchor expression statement Any))) - (function (_ (^@ stateE [bundle state])) + (function (_ [bundle state]) (case (:: (get@ #host state) <name> (temp-label state) code) (#error.Error error) (ex.throw cannot-interpret error) (#error.Success output) - (#error.Success [stateE output]))))] + (#error.Success [[bundle (update@ #counter inc state)] + output]))))] [evaluate! expression] [execute! statement] @@ -194,7 +195,7 @@ (def: #export (define! name code) (All [anchor expression statement] - (-> Name expression (Operation anchor expression statement Any))) + (-> Name expression (Operation anchor expression statement [Text Any]))) (function (_ (^@ stateE [bundle state])) (case (:: (get@ #host state) define! name code) (#error.Error error) diff --git a/stdlib/source/lux/compiler/default/reference.lux b/stdlib/source/lux/compiler/default/reference.lux index 0bbeb2db5..cde1f5b5c 100644 --- a/stdlib/source/lux/compiler/default/reference.lux +++ b/stdlib/source/lux/compiler/default/reference.lux @@ -3,7 +3,10 @@ [control [equivalence (#+ Equivalence)] [hash (#+ Hash)] - pipe]]) + pipe] + [data + [text + format]]]) (type: #export Register Nat) @@ -65,3 +68,12 @@ _ #0))) + +(def: #export (%variable variable) + (Format Variable) + (case variable + (#Local local) + (format "+" (%n local)) + + (#Foreign foreign) + (format "-" (%n foreign)))) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 201c49094..b7a55dfaa 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -1589,7 +1589,7 @@ _ [return-type return-term]))] - [decorate-return-try #import-member-try? (` ((~! error.Error) (~ return-type))) (` (try (~ return-term)))] + [decorate-return-try #import-member-try? (` ((~! error.Error) (~ return-type))) (` (..try (~ return-term)))] [decorate-return-io #import-member-io? (` ((~! io.IO) (~ return-type))) (` ((~! io.io) (~ return-term)))] ) |