aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/host.jvm.lux21
-rw-r--r--stdlib/source/lux/tool/compiler/default/init.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis.lux14
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux642
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux (renamed from stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux)0
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux (renamed from stdlib/source/lux/tool/compiler/phase/extension/statement.lux)232
-rw-r--r--stdlib/source/program/compositor.lux7
-rw-r--r--stdlib/source/test/lux/host.jvm.lux56
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/analysis.lux4
-rw-r--r--stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux (renamed from stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux)0
11 files changed, 646 insertions, 343 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 14:29:58 +0000