diff options
17 files changed, 917 insertions, 344 deletions
diff --git a/documentation/research/machine_learning.md b/documentation/research/machine_learning.md index f63e36d3c..3f93192cb 100644 --- a/documentation/research/machine_learning.md +++ b/documentation/research/machine_learning.md @@ -48,6 +48,7 @@ # Meta-learning +1. https://blog.fastforwardlabs.com/2019/05/22/metalearners-learning-how-to-learn.html 1. https://www.bayeswatch.com/2018/11/30/HTYM/ 1. https://bender.dreem.com/ diff --git a/documentation/research/math.md b/documentation/research/math.md index fd016f7b0..6b9b81bd4 100644 --- a/documentation/research/math.md +++ b/documentation/research/math.md @@ -140,6 +140,7 @@ # Abstract Algebra +1. [DUALITY FOR GROUPS](https://projecteuclid.org/download/pdf_1/euclid.bams/1183515045) 1. https://gowers.wordpress.com/2011/11/20/normal-subgroups-and-quotient-groups/ 1. [Abstract Algebra: Theory and Applications](http://abstract.ups.edu/) 1. [Group Theory](http://birdtracks.eu/version9.0/GroupTheory.pdf) diff --git a/documentation/research/operating_system.md b/documentation/research/operating_system.md index b65b1c238..d03f2c478 100644 --- a/documentation/research/operating_system.md +++ b/documentation/research/operating_system.md @@ -83,6 +83,7 @@ # Reference +1. [Rethinking files](https://www.devever.net/~hl/objectworld) 1. [Writing an OS in Rust (Second Edition)](https://os.phil-opp.com/) 1. https://archiveos.org/ 1. https://lwn.net/Articles/615809/ diff --git a/new-luxc/source/luxc/lang/statement/jvm.lux b/new-luxc/source/luxc/lang/statement/jvm.lux new file mode 100644 index 000000000..a21cc76c8 --- /dev/null +++ b/new-luxc/source/luxc/lang/statement/jvm.lux @@ -0,0 +1,262 @@ +(.module: + [lux (#- Definition) + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + ["." product] + [text + format] + [collection + ["." list ("#@." functor fold)] + ["." dictionary]]] + [type + ["." check (#+ Check)]] + [target + [jvm + ["." type (#+ Var Parameter Class Argument Typed Return) + [".T" lux]]]] + [tool + [compiler + ["." statement (#+ Handler Bundle)] + ["." phase + ["." generation] + [analysis + [".A" type]] + ["." extension + ["." bundle] + [analysis + ["." jvm]] + [statement + ["/" lux]]]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Anchor Inst Definition Operation Phase) + ["_" inst] + ["_." def]]]]]) + +(type: Declaration + [Text (List Text)]) + +(def: declaration + (Parser Declaration) + (<c>.form (<>.and <c>.text (<>.some <c>.text)))) + +(type: Inheritance + #FinalI + #AbstractI + #DefaultI) + +(def: inheritance + (Parser Inheritance) + ($_ <>.or + (<c>.text! "final") + (<c>.text! "abstract") + (<c>.text! "default"))) + +(type: State + #VolatileS + #FinalS + #DefaultS) + +(def: state + (Parser State) + ($_ <>.or + (<c>.text! "volatile") + (<c>.text! "final") + (<c>.text! "default"))) + +(type: Annotation Any) + +(def: annotation + (Parser Annotation) + <c>.any) + +(type: Constant + [Text (List Annotation) type.Type Code]) + +(def: constant + (Parser Constant) + (<| <c>.form + (<>.after (<c>.text! "constant")) + ($_ <>.and + <c>.text + (<c>.tuple (<>.some ..annotation)) + jvm.type + <c>.any + ))) + +(type: Variable + [Text jvm.Visibility State (List Annotation) type.Type]) + +(def: variable + (Parser Variable) + (<| <c>.form + (<>.after (<c>.text! "variable")) + ($_ <>.and + <c>.text + jvm.visibility + ..state + (<c>.tuple (<>.some ..annotation)) + jvm.type + ))) + +(type: Field + (#Constant Constant) + (#Variable Variable)) + +(def: field + (Parser Field) + ($_ <>.or + ..constant + ..variable + )) + +(type: Method-Definition + (#Constructor (jvm.Constructor Code)) + (#Virtual-Method (jvm.Virtual-Method Code)) + (#Static-Method (jvm.Static-Method Code)) + (#Overriden-Method (jvm.Overriden-Method Code))) + +(def: method + (Parser Method-Definition) + ($_ <>.or + jvm.constructor-definition + jvm.virtual-method-definition + jvm.static-method-definition + jvm.overriden-method-definition + )) + +(def: (parameter name) + (-> Text Parameter) + [name [type.object-class (list)] (list)]) + +(def: string-descriptor (type.descriptor (type.class "java.lang.String" (list)))) + +(def: parameter-types + (-> (List Var) (Check (List [Var Type]))) + (monad.map check.monad + (function (_ parameterJ) + (do check.monad + [[_ parameterT] check.var] + (wrap [parameterJ parameterT]))))) + +(def: jvm::class + (Handler Anchor Inst Definition) + (/.custom + [($_ <>.and + ..declaration + jvm.class + (<c>.tuple (<>.some jvm.class)) + ..inheritance + (<c>.tuple (<>.some ..annotation)) + (<c>.tuple (<>.some ..field)) + (<c>.tuple (<>.some ..method))) + (function (_ extension phase + [[name parameters] + super-class + super-interfaces + inheritance + ## TODO: Handle annotations. + annotations + fields + methods]) + (do phase.monad + [parameters (statement.lift-analysis + (typeA.with-env + (parameter-types parameters))) + #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping) + (dictionary.put parameterJ parameterT mapping)) + luxT.fresh + parameters) + field-definitions (|> fields + (list@map (function (_ field) + (case field + ## TODO: Handle annotations. + (#Constant [name annotations type value]) + (case [(type.descriptor type) value] + (^template [<descriptor> <tag> <field>] + (^ [(static <descriptor>) [_ (<tag> value)]]) + (<field> #$.Public $.finalF name value)) + ([type.boolean-descriptor #.Bit _def.boolean-field] + [type.byte-descriptor #.Int _def.byte-field] + [type.short-descriptor #.Int _def.short-field] + [type.int-descriptor #.Int _def.int-field] + [type.long-descriptor #.Int _def.long-field] + [type.float-descriptor #.Frac _def.float-field] + [type.double-descriptor #.Frac _def.double-field] + [type.char-descriptor #.Nat _def.char-field] + [string-descriptor #.Text _def.string-field]) + + ## TODO: Handle constants better. + _ + (undefined)) + + ## TODO: Handle annotations. + (#Variable [name visibility state annotations type]) + (_def.field visibility + (case state + ## TODO: Handle transient & static. + #VolatileS $.volatileF + #FinalS $.finalF + #DefaultS $.noneF) + name + type)))) + _def.fuse)] + super-classT (statement.lift-analysis + (typeA.with-env + (luxT.class mapping super-class))) + super-interfaceT+ (statement.lift-analysis + (typeA.with-env + (monad.map check.monad + (luxT.class mapping) + super-interfaces))) + #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list@map product.right parameters)) + super-classT + super-interfaceT+)] + state (extension.lift phase.get-state) + #let [analyse (get@ [#statement.analysis #statement.phase] state) + synthesize (get@ [#statement.synthesis #statement.phase] state) + generate (get@ [#statement.generation #statement.phase] state)] + methods (monad.map @ (function (_ methodC) + (do @ + [methodA (statement.lift-analysis + (case methodC + (#Constructor method) + (jvm.analyse-constructor-method analyse selfT mapping method) + + (#Virtual-Method method) + (jvm.analyse-virtual-method analyse selfT mapping method) + + (#Static-Method method) + (jvm.analyse-static-method analyse mapping method) + + (#Overriden-Method method) + (jvm.analyse-overriden-method analyse selfT mapping method)))] + (statement.lift-synthesis + (synthesize methodA)))) + methods) + _ (statement.lift-generation + (generation.save! true ["" name] + [name + (_def.class #$.V1_6 #$.Public + (case inheritance + #FinalI $.finalC + ## TODO: Handle abstract classes. + #AbstractI (undefined) + #DefaultI $.noneC) + name (list@map (|>> product.left ..parameter) parameters) + super-class super-interfaces + (|>> field-definitions))])) + #let [_ (log! (format "Class " name))]] + (wrap statement.no-requirements)))])) + +(def: #export bundle + (Bundle Anchor Inst Definition) + (<| (bundle.prefix "jvm") + (|> bundle.empty + (dictionary.put "class" jvm::class) + ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index 4239a89aa..ce5d797b4 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -886,7 +886,8 @@ (def: overriden-method-definition (Parser [Environment (/.Overriden-Method Synthesis)]) (<s>.tuple (do <>.monad - [ownerT ..class + [_ (<s>.text! /.overriden-tag) + ownerT ..class name <s>.text strict-fp? <s>.bit annotations (<s>.tuple (<>.some ..annotation)) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 8a00858b1..9f5627ee3 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -32,6 +32,8 @@ ["_" jvm ["$d" def] ["$i" inst]]] + [statement + [".S" jvm]] [translation ["." jvm ["." runtime] @@ -150,6 +152,7 @@ $i.RETURN))))])) (def: #export bundle + _.Bundle (dictionary.merge common.bundle host.bundle)) @@ -157,5 +160,6 @@ (/.compiler ..expander ..jvm ..bundle + jvmS.bundle ..program service)) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index c6d636e82..0c15560c0 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -207,6 +207,7 @@ (type: Method-Definition (#ConstructorMethod [Bit (List Var) + Text (List Argument) (List (Typed Code)) Code @@ -526,7 +527,7 @@ (def: (method->parser class-name [[method-name _ _] meth-def]) (-> Text [Member-Declaration Method-Definition] (Parser Code)) (case meth-def - (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) + (#ConstructorMethod strict? type-vars self-name args constructor-args return-expr exs) (make-constructor-parser class-name args) (#StaticMethod strict? type-vars args return-type return-expr exs) @@ -753,8 +754,10 @@ strict-fp? (p.parses? (s.this! (' #strict))) method-vars (p.default (list) ..vars^) #let [total-vars (list@compose class-vars method-vars)] - [_ arguments] (s.form (p.and (s.this! (' new)) - (arguments^ imports total-vars))) + [_ self-name arguments] (s.form ($_ p.and + (s.this! (' new)) + s.local-identifier + (arguments^ imports total-vars))) constructor-args (constructor-args^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) @@ -762,7 +765,7 @@ (wrap [{#member-name constructor-method-name #member-privacy pm #member-anns annotations} - (#ConstructorMethod strict-fp? method-vars arguments constructor-args body exs)])))) + (#ConstructorMethod strict-fp? method-vars self-name arguments constructor-args body exs)])))) (def: (virtual-method-def^ imports class-vars) (-> Class-Imports (List Var) (Parser [Member-Declaration Method-Definition])) @@ -1100,13 +1103,14 @@ (def: (method-def$ replacer super-class [[name pm anns] method-def]) (-> (-> Code Code) Class [Member-Declaration Method-Definition] Code) (case method-def - (#ConstructorMethod strict-fp? type-vars arguments constructor-args body exs) + (#ConstructorMethod strict-fp? type-vars self-name arguments constructor-args body exs) (` ("init" (~ (privacy-modifier$ pm)) (~ (code.bit strict-fp?)) [(~+ (list@map annotation$ anns))] [(~+ (list@map var$ type-vars))] [(~+ (list@map class$ exs))] + (~ (code.text self-name)) [(~+ (list@map argument$ arguments))] [(~+ (list@map constructor-arg$ constructor-args))] (~ (pre-walk-replace replacer body)) @@ -1248,7 +1252,12 @@ (p.fail "") (list@compose field-parsers method-parsers)))]] (wrap (list (` ("jvm class" - (~ (declaration$ declaration)) + (~ (declaration$ (update@ #class-name + (|>> (format (text.replace-all ..binary-class-separator + ..syntax-class-separator + current-module) + ..syntax-class-separator)) + declaration))) (~ (class$ super)) [(~+ (list@map class$ interfaces))] (~ (inheritance-modifier$ im)) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index a7a861289..28c0efb76 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -35,7 +35,8 @@ ["." extension [".E" analysis] [".E" synthesis] - [".E" statement]]] + [statement + [".S" lux]]]] [meta [archive ["." signature] @@ -58,19 +59,21 @@ #.version //.version #.mode #.Build}) -(def: #export (state expander host generate generation-bundle program) +(def: #export (state expander host generate generation-bundle host-statement-bundle program) (All [anchor expression statement] (-> Expander (generation.Host expression statement) (generation.Phase anchor expression statement) (generation.Bundle anchor expression statement) + (///statement.Bundle anchor expression statement) (-> expression statement) (///statement.State+ anchor expression statement))) (let [synthesis-state [synthesisE.bundle ///synthesis.init] generation-state [generation-bundle (generation.state host)] eval (//evaluation.evaluator expander synthesis-state generation-state generate) analysis-state [(analysisE.bundle eval) (///analysis.state ..info host)]] - [(statementE.bundle expander program) + [(dictionary.merge (luxS.bundle expander program) + host-statement-bundle) {#///statement.analysis {#///statement.state analysis-state #///statement.phase (analysisP.phase expander)} #///statement.synthesis {#///statement.state synthesis-state diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 164a81730..10a27403e 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -56,11 +56,12 @@ <State+> (as-is (///statement.State+ anchor expression statement)) <Bundle> (as-is (generation.Bundle anchor expression statement))] - (def: #export (initialize expander platform generation-bundle program) + (def: #export (initialize expander platform generation-bundle host-statement-bundle program) (All <type-vars> (-> Expander <Platform> <Bundle> + (///statement.Bundle anchor expression statement) (-> expression statement) (! (Error <State+>)))) (|> platform @@ -70,6 +71,7 @@ (get@ #host platform) (get@ #phase platform) generation-bundle + host-statement-bundle program)) (:: error.functor map product.left) (:: (get@ #&monad platform) wrap)) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux index ca2d75e4d..694f0345f 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux @@ -8,13 +8,13 @@ [default [evaluation (#+ Eval)]] [analysis (#+ Bundle)]] - [/ - ["." common] - ["." (~~ (.for {"{old}" jvm - "JVM" jvm}))]])) + ["." / #_ + ["#." lux] + ["#." (~~ (.for {"{old}" jvm + "JVM" jvm}))]])) (def: #export (bundle eval) (-> Eval Bundle) - (dictionary.merge (`` (for {(~~ (static @.old)) jvm.bundle - (~~ (static @.jvm)) jvm.bundle})) - (common.bundle eval))) + (dictionary.merge (`` (for {(~~ (static @.old)) /jvm.bundle + (~~ (static @.jvm)) /jvm.bundle})) + (/lux.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux index 616f030a9..a013c564e 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -5,8 +5,8 @@ [abstract ["." monad (#+ do)]] [control - ["p" parser - ["s" code (#+ Parser)] + ["<>" parser + ["<c>" code (#+ Parser)] ["<t>" text]] ["." exception (#+ exception:)] pipe] @@ -31,7 +31,7 @@ ["." reflection] [".T" lux (#+ Mapping)]]]]] ["." // #_ - ["#." common (#+ custom)] + ["#." lux (#+ custom)] ["/#" // ["#." bundle] ["/#" // ("#@." monad) @@ -45,7 +45,7 @@ ["#." synthesis]]]]]) (def: inheritance-relationship-type-name "_jvm_inheritance") -(def: (inheritance-relationship-type class super-class super-interfaces) +(def: #export (inheritance-relationship-type class super-class super-interfaces) (-> .Type .Type (List .Type) .Type) (#.Primitive ..inheritance-relationship-type-name (list& class super-class super-interfaces))) @@ -83,7 +83,7 @@ (def: member (Parser Member) - ($_ p.and s.text s.text)) + ($_ <>.and <c>.text <c>.text)) (type: Method-Signature {#method .Type @@ -149,29 +149,29 @@ Bundle (<| (///bundle.prefix "conversion") (|> ///bundle.empty - (///bundle.install "double-to-float" (//common.unary ..double ..float)) - (///bundle.install "double-to-int" (//common.unary ..double ..int)) - (///bundle.install "double-to-long" (//common.unary ..double ..long)) - (///bundle.install "float-to-double" (//common.unary ..float ..double)) - (///bundle.install "float-to-int" (//common.unary ..float ..int)) - (///bundle.install "float-to-long" (//common.unary ..float ..long)) - (///bundle.install "int-to-byte" (//common.unary ..int ..byte)) - (///bundle.install "int-to-char" (//common.unary ..int ..char)) - (///bundle.install "int-to-double" (//common.unary ..int ..double)) - (///bundle.install "int-to-float" (//common.unary ..int ..float)) - (///bundle.install "int-to-long" (//common.unary ..int ..long)) - (///bundle.install "int-to-short" (//common.unary ..int ..short)) - (///bundle.install "long-to-double" (//common.unary ..long ..double)) - (///bundle.install "long-to-float" (//common.unary ..long ..float)) - (///bundle.install "long-to-int" (//common.unary ..long ..int)) - (///bundle.install "long-to-short" (//common.unary ..long ..short)) - (///bundle.install "long-to-byte" (//common.unary ..long ..byte)) - (///bundle.install "char-to-byte" (//common.unary ..char ..byte)) - (///bundle.install "char-to-short" (//common.unary ..char ..short)) - (///bundle.install "char-to-int" (//common.unary ..char ..int)) - (///bundle.install "char-to-long" (//common.unary ..char ..long)) - (///bundle.install "byte-to-long" (//common.unary ..byte ..long)) - (///bundle.install "short-to-long" (//common.unary ..short ..long)) + (///bundle.install "double-to-float" (//lux.unary ..double ..float)) + (///bundle.install "double-to-int" (//lux.unary ..double ..int)) + (///bundle.install "double-to-long" (//lux.unary ..double ..long)) + (///bundle.install "float-to-double" (//lux.unary ..float ..double)) + (///bundle.install "float-to-int" (//lux.unary ..float ..int)) + (///bundle.install "float-to-long" (//lux.unary ..float ..long)) + (///bundle.install "int-to-byte" (//lux.unary ..int ..byte)) + (///bundle.install "int-to-char" (//lux.unary ..int ..char)) + (///bundle.install "int-to-double" (//lux.unary ..int ..double)) + (///bundle.install "int-to-float" (//lux.unary ..int ..float)) + (///bundle.install "int-to-long" (//lux.unary ..int ..long)) + (///bundle.install "int-to-short" (//lux.unary ..int ..short)) + (///bundle.install "long-to-double" (//lux.unary ..long ..double)) + (///bundle.install "long-to-float" (//lux.unary ..long ..float)) + (///bundle.install "long-to-int" (//lux.unary ..long ..int)) + (///bundle.install "long-to-short" (//lux.unary ..long ..short)) + (///bundle.install "long-to-byte" (//lux.unary ..long ..byte)) + (///bundle.install "char-to-byte" (//lux.unary ..char ..byte)) + (///bundle.install "char-to-short" (//lux.unary ..char ..short)) + (///bundle.install "char-to-int" (//lux.unary ..char ..int)) + (///bundle.install "char-to-long" (//lux.unary ..char ..long)) + (///bundle.install "byte-to-long" (//lux.unary ..byte ..long)) + (///bundle.install "short-to-long" (//lux.unary ..short ..long)) ))) (template [<name> <prefix> <type>] @@ -179,19 +179,19 @@ Bundle (<| (///bundle.prefix <prefix>) (|> ///bundle.empty - (///bundle.install "+" (//common.binary <type> <type> <type>)) - (///bundle.install "-" (//common.binary <type> <type> <type>)) - (///bundle.install "*" (//common.binary <type> <type> <type>)) - (///bundle.install "/" (//common.binary <type> <type> <type>)) - (///bundle.install "%" (//common.binary <type> <type> <type>)) - (///bundle.install "=" (//common.binary <type> <type> Bit)) - (///bundle.install "<" (//common.binary <type> <type> Bit)) - (///bundle.install "and" (//common.binary <type> <type> <type>)) - (///bundle.install "or" (//common.binary <type> <type> <type>)) - (///bundle.install "xor" (//common.binary <type> <type> <type>)) - (///bundle.install "shl" (//common.binary <type> Integer <type>)) - (///bundle.install "shr" (//common.binary <type> Integer <type>)) - (///bundle.install "ushr" (//common.binary <type> Integer <type>)) + (///bundle.install "+" (//lux.binary <type> <type> <type>)) + (///bundle.install "-" (//lux.binary <type> <type> <type>)) + (///bundle.install "*" (//lux.binary <type> <type> <type>)) + (///bundle.install "/" (//lux.binary <type> <type> <type>)) + (///bundle.install "%" (//lux.binary <type> <type> <type>)) + (///bundle.install "=" (//lux.binary <type> <type> Bit)) + (///bundle.install "<" (//lux.binary <type> <type> Bit)) + (///bundle.install "and" (//lux.binary <type> <type> <type>)) + (///bundle.install "or" (//lux.binary <type> <type> <type>)) + (///bundle.install "xor" (//lux.binary <type> <type> <type>)) + (///bundle.install "shl" (//lux.binary <type> Integer <type>)) + (///bundle.install "shr" (//lux.binary <type> Integer <type>)) + (///bundle.install "ushr" (//lux.binary <type> Integer <type>)) )))] [bundle::int reflection.int ..long] @@ -203,13 +203,13 @@ Bundle (<| (///bundle.prefix <prefix>) (|> ///bundle.empty - (///bundle.install "+" (//common.binary <type> <type> <type>)) - (///bundle.install "-" (//common.binary <type> <type> <type>)) - (///bundle.install "*" (//common.binary <type> <type> <type>)) - (///bundle.install "/" (//common.binary <type> <type> <type>)) - (///bundle.install "%" (//common.binary <type> <type> <type>)) - (///bundle.install "=" (//common.binary <type> <type> Bit)) - (///bundle.install "<" (//common.binary <type> <type> Bit)) + (///bundle.install "+" (//lux.binary <type> <type> <type>)) + (///bundle.install "-" (//lux.binary <type> <type> <type>)) + (///bundle.install "*" (//lux.binary <type> <type> <type>)) + (///bundle.install "/" (//lux.binary <type> <type> <type>)) + (///bundle.install "%" (//lux.binary <type> <type> <type>)) + (///bundle.install "=" (//lux.binary <type> <type> Bit)) + (///bundle.install "<" (//lux.binary <type> <type> Bit)) )))] [bundle::float reflection.float ..float] @@ -220,8 +220,8 @@ Bundle (<| (///bundle.prefix reflection.char) (|> ///bundle.empty - (///bundle.install "=" (//common.binary ..char ..char Bit)) - (///bundle.install "<" (//common.binary ..char ..char Bit)) + (///bundle.install "=" (//lux.binary ..char ..char Bit)) + (///bundle.install "<" (//lux.binary ..char ..char Bit)) ))) (def: #export boxes @@ -635,7 +635,7 @@ (def: object::instance? Handler (..custom - [($_ p.and s.text s.any) + [($_ <>.and <c>.text <c>.any) (function (_ extension-name analyse [sub-class objectC]) (do ////.monad [_ (typeA.infer Bit) @@ -842,7 +842,7 @@ (def: static::put Handler (..custom - [($_ p.and ..member s.any) + [($_ <>.and ..member <c>.any) (function (_ extension-name analyse [[class field] valueC]) (do ////.monad [_ (typeA.infer Any) @@ -863,7 +863,7 @@ (def: virtual::get Handler (..custom - [($_ p.and ..member s.any) + [($_ <>.and ..member <c>.any) (function (_ extension-name analyse [[class field] objectC]) (do ////.monad [[objectT objectA] (typeA.with-inference @@ -885,7 +885,7 @@ (def: virtual::put Handler (..custom - [($_ p.and ..member s.any s.any) + [($_ <>.and ..member <c>.any <c>.any) (function (_ extension-name analyse [[class field] valueC objectC]) (do ////.monad [[objectT objectA] (typeA.with-inference @@ -1127,7 +1127,7 @@ (def: typed-input (Parser [Text Code]) - (s.tuple (p.and s.text s.any))) + (<c>.tuple (<>.and <c>.text <c>.any))) (def: (decorate-inputs typesT inputsA) (-> (List Text) (List Analysis) (List Analysis)) @@ -1139,7 +1139,7 @@ (def: invoke::static Handler (..custom - [($_ p.and ..member (p.some ..typed-input)) + [($_ <>.and ..member (<>.some ..typed-input)) (function (_ extension-name analyse [[class method] argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1154,7 +1154,7 @@ (def: invoke::virtual Handler (..custom - [($_ p.and ..member s.any (p.some ..typed-input)) + [($_ <>.and ..member <c>.any (<>.some ..typed-input)) (function (_ extension-name analyse [[class method] objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1176,7 +1176,7 @@ (def: invoke::special Handler (..custom - [($_ p.and ..member s.any (p.some ..typed-input)) + [($_ <>.and ..member <c>.any (<>.some ..typed-input)) (function (_ extension-name analyse [[class method] objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1191,7 +1191,7 @@ (def: invoke::interface Handler (..custom - [($_ p.and ..member s.any (p.some ..typed-input)) + [($_ <>.and ..member <c>.any (<>.some ..typed-input)) (function (_ extension-name analyse [[class-name method] objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1216,7 +1216,7 @@ (def: invoke::constructor (..custom - [($_ p.and s.text (p.some ..typed-input)) + [($_ <>.and <c>.text (<>.some ..typed-input)) (function (_ extension-name analyse [class argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1247,113 +1247,81 @@ ))) ))) -(def: var +(def: #export var (Parser Var) - s.text) + <c>.text) (def: bound (Parser Bound) - (p.or (s.identifier! ["" ">"]) - (s.identifier! ["" "<"]))) + (<>.or (<c>.identifier! ["" ">"]) + (<c>.identifier! ["" "<"]))) (def: generic (Parser Generic) - (p.rec + (<>.rec (function (_ generic) (let [wildcard (: (Parser (Maybe [Bound Generic])) - (p.or (s.identifier! ["" "?"]) - (s.form (p.and ..bound generic)))) + (<>.or (<c>.identifier! ["" "?"]) + (<c>.form (<>.and ..bound generic)))) class (: (Parser Class) - (s.form (p.and s.text (p.some generic))))] - ($_ p.or + (<c>.form (<>.and <c>.text (<>.some generic))))] + ($_ <>.or ..var wildcard class))))) -(def: class +(def: #export class (Parser Class) - (s.form (p.and s.text (p.some ..generic)))) + (<c>.form (<>.and <c>.text (<>.some ..generic)))) (def: primitive (Parser Primitive) - ($_ p.or - (s.identifier! ["" reflection.boolean]) - (s.identifier! ["" reflection.byte]) - (s.identifier! ["" reflection.short]) - (s.identifier! ["" reflection.int]) - (s.identifier! ["" reflection.long]) - (s.identifier! ["" reflection.float]) - (s.identifier! ["" reflection.double]) - (s.identifier! ["" reflection.char]) + ($_ <>.or + (<c>.identifier! ["" reflection.boolean]) + (<c>.identifier! ["" reflection.byte]) + (<c>.identifier! ["" reflection.short]) + (<c>.identifier! ["" reflection.int]) + (<c>.identifier! ["" reflection.long]) + (<c>.identifier! ["" reflection.float]) + (<c>.identifier! ["" reflection.double]) + (<c>.identifier! ["" reflection.char]) )) -(def: type +(def: #export type (Parser Type) - (p.rec + (<>.rec (function (_ type) - ($_ p.or + ($_ <>.or ..primitive ..generic - (s.tuple type))))) + (<c>.tuple type))))) -(def: typed +(def: #export typed (Parser (Typed Code)) - (s.tuple (p.and ..type s.any))) + (<c>.tuple (<>.and ..type <c>.any))) (type: #export (Annotation-Parameter a) [Text a]) (def: annotation-parameter (Parser (Annotation-Parameter Code)) - (s.tuple (p.and s.text s.any))) + (<c>.tuple (<>.and <c>.text <c>.any))) (type: #export (Annotation a) [Text (List (Annotation-Parameter a))]) -(def: annotation +(def: #export annotation (Parser (Annotation Code)) - (s.form (p.and s.text (p.some ..annotation-parameter)))) + (<c>.form (<>.and <c>.text (<>.some ..annotation-parameter)))) -(def: argument +(def: #export argument (Parser Argument) - (s.tuple (p.and s.text ..type))) + (<c>.tuple (<>.and <c>.text ..type))) -(def: return +(def: #export return (Parser Return) - (p.or (s.identifier! ["" reflection.void]) - ..type)) - -(type: #export (Overriden-Method a) - [Class - Text - Bit - (List (Annotation a)) - (List Var) - Text - (List Argument) - Return - (List Class) - a]) - -(type: #export (Method-Definition a) - (#Overriden-Method (Overriden-Method a))) - -(def: overriden-method-definition - (Parser (Overriden-Method Code)) - (<| s.form - (p.after (s.text! "override")) - ($_ p.and - ..class - s.text - s.bit - (s.tuple (p.some ..annotation)) - (s.tuple (p.some ..var)) - s.text - (s.tuple (p.some ..argument)) - ..return - (s.tuple (p.some ..class)) - s.any - ))) + (<>.or (<c>.identifier! ["" reflection.void]) + ..type)) (def: (generic-analysis generic) (-> Generic Analysis) @@ -1479,14 +1447,378 @@ [invalid-overriden-methods] ) +(type: #export Visibility + #PublicV + #PrivateV + #ProtectedV + #DefaultV) + +(type: #export Finality Bit) +(type: #export Strictness Bit) + +(def: #export public-tag "public") +(def: #export private-tag "private") +(def: #export protected-tag "protected") +(def: #export default-tag "default") + +(def: #export visibility + (Parser Visibility) + ($_ <>.or + (<c>.text! ..public-tag) + (<c>.text! ..private-tag) + (<c>.text! ..protected-tag) + (<c>.text! ..default-tag))) + +(type: #export (Constructor a) + [Visibility + Strictness + (List (Annotation a)) + (List Var) + (List Class) ## Exceptions + Text + (List Argument) + (List (Typed a)) + a]) + +(def: #export constructor-tag "init") + +(def: #export constructor-definition + (Parser (Constructor Code)) + (<| <c>.form + (<>.after (<c>.text! ..constructor-tag)) + ($_ <>.and + ..visibility + <c>.bit + (<c>.tuple (<>.some ..annotation)) + (<c>.tuple (<>.some ..var)) + (<c>.tuple (<>.some ..class)) + <c>.text + (<c>.tuple (<>.some ..argument)) + (<c>.tuple (<>.some ..typed)) + <c>.any))) + +(def: #export (analyse-constructor-method analyse selfT mapping method) + (-> Phase .Type Mapping (Constructor Code) (Operation Analysis)) + (let [[visibility strict-fp? + annotations vars exceptions + self-name arguments super-arguments body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + super-arguments (monad.map @ (function (_ [jvmT super-argC]) + (do @ + [luxT (typeA.with-env + (luxT.type mapping jvmT)) + super-argA (typeA.with-type luxT + (analyse super-argC))] + (wrap [jvmT super-argA]))) + super-arguments) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type .Any) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..constructor-tag) + (/////analysis.text (case visibility + #PublicV ..public-tag + #PrivateV ..private-tag + #ProtectedV ..protected-tag + #DefaultV ..default-tag)) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (/////analysis.tuple (list@map typed-analysis + super-arguments)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Virtual-Method a) + [Text + Visibility + Finality + Strictness + (List (Annotation a)) + (List Var) + Text + (List Argument) + Return + (List Class) ## Exceptions + a]) + +(def: virtual-tag "virtual") + +(def: #export virtual-method-definition + (Parser (Virtual-Method Code)) + (<| <c>.form + (<>.after (<c>.text! ..virtual-tag)) + ($_ <>.and + <c>.text + ..visibility + <c>.bit + <c>.bit + (<c>.tuple (<>.some ..annotation)) + (<c>.tuple (<>.some ..var)) + <c>.text + (<c>.tuple (<>.some ..argument)) + ..return + (<c>.tuple (<>.some ..class)) + <c>.any))) + +(def: #export (analyse-virtual-method analyse selfT mapping method) + (-> Phase .Type Mapping (Virtual-Method Code) (Operation Analysis)) + (let [[method-name visibility + final? strict-fp? annotations vars + self-name arguments return exceptions + body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (typeA.with-env + (luxT.return mapping return)) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type returnT) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..virtual-tag) + (/////analysis.text method-name) + (/////analysis.text (case visibility + #PublicV ..public-tag + #PrivateV ..private-tag + #ProtectedV ..protected-tag + #DefaultV ..default-tag)) + (/////analysis.bit final?) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (return-analysis return) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Static-Method a) + [Text + Visibility + Strictness + (List (Annotation a)) + (List Var) + (List Class) ## Exceptions + (List Argument) + Return + a]) + +(def: #export static-tag "static") + +(def: #export static-method-definition + (Parser (Static-Method Code)) + (<| <c>.form + (<>.after (<c>.text! ..static-tag)) + ($_ <>.and + <c>.text + ..visibility + <c>.bit + (<c>.tuple (<>.some ..annotation)) + (<c>.tuple (<>.some ..var)) + (<c>.tuple (<>.some ..class)) + (<c>.tuple (<>.some ..argument)) + ..return + <c>.any))) + +(def: #export (analyse-static-method analyse mapping method) + (-> Phase Mapping (Static-Method Code) (Operation Analysis)) + (let [[method-name visibility + strict-fp? annotations vars exceptions + arguments return + body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (typeA.with-env + (luxT.return mapping return)) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type returnT) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..static-tag) + (/////analysis.text method-name) + (/////analysis.text (case visibility + #PublicV ..public-tag + #PrivateV ..private-tag + #ProtectedV ..protected-tag + #DefaultV ..default-tag)) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (return-analysis return) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Overriden-Method a) + [Class + Text + Bit + (List (Annotation a)) + (List Var) + Text + (List Argument) + Return + (List Class) + a]) + +(def: #export overriden-tag "override") + +(def: #export overriden-method-definition + (Parser (Overriden-Method Code)) + (<| <c>.form + (<>.after (<c>.text! ..overriden-tag)) + ($_ <>.and + ..class + <c>.text + <c>.bit + (<c>.tuple (<>.some ..annotation)) + (<c>.tuple (<>.some ..var)) + <c>.text + (<c>.tuple (<>.some ..argument)) + ..return + (<c>.tuple (<>.some ..class)) + <c>.any + ))) + +(def: #export (analyse-overriden-method analyse selfT mapping method) + (-> Phase .Type Mapping (Overriden-Method Code) (Operation Analysis)) + (let [[parent-type method-name + strict-fp? annotations vars + self-name arguments return exceptions + body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (typeA.with-env + (luxT.return mapping return)) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type returnT) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..overriden-tag) + (class-analysis parent-type) + (/////analysis.text method-name) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (return-analysis return) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Method-Definition a) + (#Overriden-Method (Overriden-Method a))) + (def: class::anonymous Handler (..custom - [($_ p.and + [($_ <>.and ..class - (s.tuple (p.some ..class)) - (s.tuple (p.some ..typed)) - (s.tuple (p.some ..overriden-method-definition))) + (<c>.tuple (<>.some ..class)) + (<c>.tuple (<>.some ..typed)) + (<c>.tuple (<>.some ..overriden-method-definition))) (function (_ extension-name analyse [super-class super-interfaces constructor-args @@ -1515,55 +1847,7 @@ (analyse term))] (wrap [type termA]))) constructor-args) - methodsA (monad.map @ (function (_ [parent-type method-name - strict-fp? annotations vars - self-name arguments return exceptions - body]) - - (do @ - [annotationsA (monad.map @ (function (_ [name parameters]) - (do @ - [parametersA (monad.map @ (function (_ [name value]) - (do @ - [valueA (analyse value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (typeA.with-env - (luxT.return luxT.fresh return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type luxT.fresh jvmT)] - (wrap [name luxT]))) - arguments)) - [scope bodyA] (|> arguments' - (#.Cons [self-name selfT]) - list.reverse - (list@fold scope.with-local (analyse body)) - (typeA.with-type returnT) - /////analysis.with-scope)] - (wrap (/////analysis.tuple (list (class-analysis parent-type) - (/////analysis.text method-name) - (/////analysis.bit strict-fp?) - (/////analysis.tuple (list@map annotation-analysis annotationsA)) - (/////analysis.tuple (list@map var-analysis vars)) - (/////analysis.text self-name) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) - (return-analysis return) - (/////analysis.tuple (list@map class-analysis - exceptions)) - (#/////analysis.Function - (scope.environment scope) - (/////analysis.tuple (list bodyA))) - ))))) - methods) + methodsA (monad.map @ (analyse-overriden-method analyse selfT luxT.fresh) methods) required-abstract-methods (////.lift (all-abstract-methods (list& super-class super-interfaces))) available-methods (////.lift (all-methods (list& super-class super-interfaces))) #let [overriden-methods (list@map (function (_ [parent-type method-name diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux index 51402fad8..51402fad8 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux 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))))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index c39544019..7d058ec0e 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -78,11 +78,12 @@ (#error.Failure error) (:: io.monad wrap (#error.Failure error))))) -(def: #export (compiler expander platform bundle program service) +(def: #export (compiler expander platform generation-bundle host-statement-bundle program service) (All [anchor expression statement] (-> Expander (IO (Platform IO anchor expression statement)) (generation.Bundle anchor expression statement) + (statement.Bundle anchor expression statement) (-> expression statement) Service (IO Any))) @@ -97,7 +98,7 @@ {(Platform IO anchor expression statement) platform} {(IO (Error (statement.State+ anchor expression statement))) - (platform.initialize expander platform bundle program)}) + (platform.initialize expander platform generation-bundle host-statement-bundle program)}) [archive state] (:share [anchor expression statement] {(Platform IO anchor expression statement) platform} @@ -112,5 +113,5 @@ ## TODO: Fix the interpreter... (undefined) ## (<| (or-crash! "Interpretation failed:") - ## (interpreter.run (error.with io.monad) console platform configuration bundle)) + ## (interpreter.run (error.with io.monad) console platform configuration generation-bundle)) ))) diff --git a/stdlib/source/test/lux/host.jvm.lux b/stdlib/source/test/lux/host.jvm.lux index c9446b857..f142a1912 100644 --- a/stdlib/source/test/lux/host.jvm.lux +++ b/stdlib/source/test/lux/host.jvm.lux @@ -11,28 +11,32 @@ {1 ["." / (#+ import: class: interface: object)]}) -(import: (java/util/concurrent/Callable a)) +(import: #long (java/util/concurrent/Callable a)) -(import: java/lang/Exception - (new [String])) +(import: #long java/lang/String) -(import: java/lang/Object) +(import: #long java/lang/Exception + (new [java/lang/String])) -(import: (java/lang/Class a) - (getName [] String)) +(import: #long java/lang/Object) -(import: java/lang/System +(import: #long (java/lang/Class a) + (getName [] java/lang/String)) + +(import: #long java/lang/Runnable) + +(import: #long java/lang/System (#static out java/io/PrintStream) (#static currentTimeMillis [] #io long) - (#static getenv [String] #io #? String)) + (#static getenv [java/lang/String] #io #? java/lang/String)) -(class: #final (TestClass A) [Runnable] +(class: #final (TestClass A) [java/lang/Runnable] ## Fields (#private foo boolean) (#private bar A) (#private baz java/lang/Object) ## Methods - (#public [] (new {value A}) [] + (#public [] (new self {value A}) [] (exec (:= ::foo #1) (:= ::bar value) (:= ::baz "") @@ -41,23 +45,23 @@ "") (#public #static (static) java/lang/Object "") - (Runnable [] (run self) void - [])) + (java/lang/Runnable [] (run self) void + [])) (def: test-runnable - (object [] [Runnable] + (object [] [java/lang/Runnable] [] - (Runnable [] (run self) void - []))) + (java/lang/Runnable [] (run self) void + []))) (def: test-callable - (object [a] [(Callable a)] + (object [a] [(java/util/concurrent/Callable a)] [] - (Callable [] (call self) a - (undefined)))) + (java/util/concurrent/Callable [] (call self) a + (undefined)))) (interface: TestInterface - ([] foo [boolean String] void #throws [Exception])) + ([] foo [boolean java/lang/String] void #throws [java/lang/Exception])) (def: conversions Test @@ -85,26 +89,26 @@ [sample (r.ascii 1)] ($_ _.and (_.test "Can check if an object is of a certain class." - (and (case (/.check String sample) (#.Some _) true #.None false) - (case (/.check Long sample) (#.Some _) false #.None true) - (case (/.check Object sample) (#.Some _) true #.None false) - (case (/.check Object (/.null)) (#.Some _) false #.None true))) + (and (case (/.check java/lang/String sample) (#.Some _) true #.None false) + (case (/.check java/lang/Long sample) (#.Some _) false #.None true) + (case (/.check java/lang/Object sample) (#.Some _) true #.None false) + (case (/.check java/lang/Object (/.null)) (#.Some _) false #.None true))) (_.test "Can run code in a 'synchronized' block." (/.synchronized sample #1)) (_.test "Can access Class instances." - (text;= "java.lang.Class" (Class::getName (/.class-for java/lang/Class)))) + (text;= "java.lang.Class" (java/lang/Class::getName (/.class-for java/lang/Class)))) (_.test "Can check if a value is null." (and (/.null? (/.null)) (not (/.null? sample)))) (_.test "Can safely convert nullable references into Maybe values." - (and (|> (: (Maybe Object) (/.??? (/.null))) + (and (|> (: (Maybe java/lang/Object) (/.??? (/.null))) (case> #.None #1 _ #0)) - (|> (: (Maybe Object) (/.??? sample)) + (|> (: (Maybe java/lang/Object) (/.??? sample)) (case> (#.Some _) #1 _ #0)))) ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis.lux index d24feb8be..06b09fbf9 100644 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis.lux +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis.lux @@ -10,7 +10,7 @@ ["/#" // #_ [extension [analysis - ["#." common]]]]]) + ["#." lux]]]]]) (def: #export test Test @@ -20,5 +20,5 @@ /reference.test /case.test /function.test - //common.test + //lux.test )) diff --git a/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux index e45656025..e45656025 100644 --- a/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux +++ b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux |