diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux | 642 |
1 files changed, 463 insertions, 179 deletions
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 |