diff options
3 files changed, 155 insertions, 116 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux index 0a122bf3c..c69ff8eb2 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis.lux @@ -1,5 +1,7 @@ (.module: [lux (#- nat int rev) + [control + [monad (#+ do)]] [data ["." product] ["." error] @@ -60,17 +62,6 @@ (#Apply Analysis Analysis) (#Extension (Extension Analysis))) -(do-template [<special> <general>] - [(type: #export <special> - (<general> .Lux Code Analysis))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - (type: #export Branch (Branch' Analysis)) @@ -178,6 +169,81 @@ (template: #export (pattern/bind register) (#..Bind register)) +(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 + (#Variant [lefts right? value]) + (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")") + + (#Tuple members) + (|> members + (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 ["(" ")"])))) + +(do-template [<special> <general>] + [(type: #export <special> + (<general> .Lux Code Analysis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + (def: #export (with-source-code source action) (All [a] (-> Source (Operation a) (Operation a))) (function (_ [bundle state]) @@ -249,66 +315,35 @@ [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 - (#Variant [lefts right? value]) - (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")") - - (#Tuple members) - (|> members - (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 ["(" ")"])))) +(def: #export (cursor file) + (-> Text Cursor) + [file 1 0]) + +(def: #export (source file code) + (-> Text Text Source) + [(cursor file) 0 code]) + +(def: dummy-source + Source + [.dummy-cursor 0 ""]) + +(def: type-context + Type-Context + {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)}) + +(def: #export (state info host) + (-> Info Any Lux) + {#.info info + #.source ..dummy-source + #.cursor .dummy-cursor + #.current-module #.None + #.modules (list) + #.scopes (list) + #.type-context ..type-context + #.expected #.None + #.seed 0 + #.scope-type-vars (list) + #.extensions [] + #.host host}) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux index 317f86a6f..1da6520a5 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux @@ -5,10 +5,8 @@ ["ex" exception (#+ exception:)]] [data ["." error] - ["." text - format] - [collection - [list ("list/." Functor<List>)]]] + [text + format]] ["." macro]] ["." // (#+ Analysis Operation Phase) ["." type] @@ -23,33 +21,9 @@ [// ["." reference]]]]) -(exception: #export (macro-expansion-failed {macro Name} {inputs (List Code)} {error Text}) - (ex.report ["Macro" (%name macro)] - ["Inputs" (|> inputs - (list/map (|>> %code (format text.new-line text.tab))) - (text.join-with ""))] - ["Error" error])) - -(exception: #export (macro-call-must-have-single-expansion {macro Name} {inputs (List Code)}) - (ex.report ["Macro" (%name macro)] - ["Inputs" (|> inputs - (list/map (|>> %code (format text.new-line text.tab))) - (text.join-with ""))])) - (exception: #export (unrecognized-syntax {code Code}) (ex.report ["Code" (%code code)])) -(def: #export (expand-macro name macro inputs) - (-> Name Macro (List Code) (Operation (List Code))) - (extension.lift - (function (_ state) - (case (//macro.expand macro inputs state) - (#error.Error error) - ((///.throw macro-expansion-failed [name inputs error]) state) - - output - output)))) - (def: #export (compile code) Phase (do ///.Monad<Operation> @@ -121,13 +95,8 @@ (case ?macro (#.Some macro) (do @ - [expansion (expand-macro def-name macro argsC+)] - (case expansion - (^ (list single)) - (compile single) - - _ - (///.throw macro-call-must-have-single-expansion [def-name argsC+]))) + [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] + (compile expansion)) _ (function.apply compile functionT functionA argsC+))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux index 7aa9a01a4..af12c747d 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux @@ -1,12 +1,31 @@ (.module: [lux #* [control - [monad (#+ do)]] + [monad (#+ do)] + ["ex" exception (#+ exception:)]] [data ["." error (#+ Error)] + ["." text + format] [collection - [array (#+ Array)]]] - ["." host (#+ import:)]]) + [array (#+ Array)] + [list ("list/." Functor<List>)]]] + ["." macro] + ["." host (#+ import:)]] + ["." ///]) + +(exception: #export (expansion-failed {macro Name} {inputs (List Code)} {error Text}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format text.new-line text.tab))) + (text.join-with ""))] + ["Error" error])) + +(exception: #export (must-have-single-expansion {macro Name} {inputs (List Code)}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format text.new-line text.tab))) + (text.join-with ""))])) (import: java/lang/reflect/Method (invoke [Object (Array Object)] #try Object)) @@ -27,8 +46,8 @@ (host.array-write 0 _object-class) (host.array-write 1 _object-class))) -(def: #export (expand macro inputs) - (-> Macro (List Code) (Meta (List Code))) +(def: #export (expand name macro inputs) + (-> Name Macro (List Code) (Meta (List Code))) (function (_ state) (do error.Monad<Error> [apply-method (|> macro @@ -40,5 +59,21 @@ (host.array-write 0 (:coerce Object inputs)) (host.array-write 1 (:coerce Object state))) apply-method)] - (:coerce (Error [Lux (List Code)]) - output)))) + (case (:coerce (Error [Lux (List Code)]) + output) + (#error.Success output) + (#error.Success output) + + (#error.Error error) + ((///.throw expansion-failed [name inputs error]) state))))) + +(def: #export (expand-one name macro inputs) + (-> Name Macro (List Code) (Meta Code)) + (do macro.Monad<Meta> + [expansion (expand name macro inputs)] + (case expansion + (^ (list single)) + (wrap single) + + _ + (///.throw must-have-single-expansion [name inputs])))) |