aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/lang/analysis.lux17
-rw-r--r--stdlib/source/lux/lang/analysis/expression.lux11
-rw-r--r--stdlib/source/lux/lang/extension.lux113
-rw-r--r--stdlib/source/lux/lang/extension/analysis.lux16
-rw-r--r--stdlib/source/lux/lang/extension/analysis/common.lux444
-rw-r--r--stdlib/source/lux/lang/extension/analysis/host.jvm.lux1224
-rw-r--r--stdlib/source/lux/lang/init.lux31
-rw-r--r--stdlib/source/lux/lang/synthesis.lux8
8 files changed, 1843 insertions, 21 deletions
diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux
index 0b48f803d..324f12b3e 100644
--- a/stdlib/source/lux/lang/analysis.lux
+++ b/stdlib/source/lux/lang/analysis.lux
@@ -1,5 +1,5 @@
(.module:
- lux
+ [lux #- nat int deg]
(lux [function]
(data (coll [list "list/" Fold<List>]))))
@@ -46,7 +46,20 @@
(#Apply Analysis Analysis)
(#Variable Variable)
(#Constant Ident)
- (#Special (Special Text)))
+ (#Special (Special Analysis)))
+
+(do-template [<name> <type> <tag>]
+ [(def: #export <name>
+ (-> <type> Analysis)
+ (|>> <tag> #Primitive))]
+
+ [bool Bool #Bool]
+ [nat Nat #Nat]
+ [int Int #Int]
+ [deg Deg #Deg]
+ [frac Frac #Frac]
+ [text Text #Text]
+ )
(type: #export (Variant a)
{#lefts Nat
diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux
index da1b27a10..325394e73 100644
--- a/stdlib/source/lux/lang/analysis/expression.lux
+++ b/stdlib/source/lux/lang/analysis/expression.lux
@@ -15,8 +15,7 @@
[".A" structure]
[".A" reference])
## [".L" macro]
- ## [".L" extension]
- )))
+ [".L" extension])))
(exception: #export (macro-expansion-failed {message Text})
message)
@@ -80,10 +79,10 @@
(#.Symbol reference)
(referenceA.reference reference)
- ## (^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
- ## (do macro.Monad<Meta>
- ## [procedure (extensionL.find-analysis proc-name)]
- ## (procedure analyse eval proc-args))
+ (^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
+ (do macro.Monad<Meta>
+ [procedure (extensionL.find-analysis proc-name)]
+ (procedure analyse eval proc-args))
## (^ (#.Form (list& func args)))
## (do macro.Monad<Meta>
diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux
new file mode 100644
index 000000000..03fd81d71
--- /dev/null
+++ b/stdlib/source/lux/lang/extension.lux
@@ -0,0 +1,113 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data ["e" error]
+ [text]
+ (coll (dictionary ["dict" unordered #+ Dict])))
+ [macro])
+ [// #+ Eval]
+ (// [".L" analysis #+ Analyser]
+ [".L" synthesis]))
+
+(do-template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
+
+ [unknown-analysis]
+ [unknown-synthesis]
+ [unknown-translation]
+ [unknown-statement]
+
+ [cannot-define-analysis-more-than-once]
+ [cannot-define-synthesis-more-than-once]
+ [cannot-define-translation-more-than-once]
+ [cannot-define-statement-more-than-once]
+ )
+
+(type: #export Analysis
+ (-> Analyser Eval (List Code) (Meta analysisL.Analysis)))
+
+(type: #export Synthesis
+ (-> (-> analysisL.Analysis synthesisL.Synthesis) (List Code) Code))
+
+(type: #export Translation
+ (-> (List Code) (Meta Code)))
+
+(type: #export Statement
+ (-> (List Code) (Meta Any)))
+
+(type: #export (Extension e)
+ (Dict Text e))
+
+(type: #export Extensions
+ {#analysis (Extension Analysis)
+ #synthesis (Extension Synthesis)
+ #translation (Extension Translation)
+ #statement (Extension Statement)})
+
+(def: #export fresh
+ Extensions
+ {#analysis (dict.new text.Hash<Text>)
+ #synthesis (dict.new text.Hash<Text>)
+ #translation (dict.new text.Hash<Text>)
+ #statement (dict.new text.Hash<Text>)})
+
+(def: get
+ (Meta Extensions)
+ (function (_ compiler)
+ (#e.Success [compiler
+ (|> compiler (get@ #.extensions) (:! Extensions))])))
+
+(def: (set extensions)
+ (-> Extensions (Meta Any))
+ (function (_ compiler)
+ (#e.Success [(set@ #.extensions (:! Nothing extensions) compiler)
+ []])))
+
+(do-template [<name> <type> <category> <exception>]
+ [(def: #export (<name> name)
+ (-> Text (Meta <type>))
+ (do macro.Monad<Meta>
+ [extensions ..get]
+ (case (dict.get name (get@ <category> extensions))
+ (#.Some extension)
+ (wrap extension)
+
+ #.None
+ (//.throw <exception> name))))]
+
+ [find-analysis Analysis #analysis unknown-analysis]
+ [find-synthesis Synthesis #synthesis unknown-synthesis]
+ [find-translation Translation #translation unknown-translation]
+ [find-statement Statement #statement unknown-statement]
+ )
+
+(do-template [<no> <all> <type> <category> <empty>]
+ [(def: #export <no>
+ <type>
+ <empty>)
+
+ (def: #export <all>
+ (Meta <type>)
+ (|> ..get
+ (:: macro.Monad<Meta> map (get@ <category>))))]
+
+ [no-syntheses all-syntheses (Extension Synthesis) #synthesis (dict.new text.Hash<Text>)]
+ )
+
+(do-template [<name> <type> <category> <exception>]
+ [(def: #export (<name> name extension)
+ (-> Text <type> (Meta Any))
+ (do macro.Monad<Meta>
+ [extensions ..get
+ _ (//.assert <exception> name
+ (not (dict.contains? name (get@ <category> extensions))))
+ _ (..set (update@ <category> (dict.put name extension) extensions))]
+ (wrap [])))]
+
+ [install-analysis Analysis #analysis cannot-define-analysis-more-than-once]
+ [install-synthesis Synthesis #synthesis cannot-define-synthesis-more-than-once]
+ [install-translation Translation #translation cannot-define-translation-more-than-once]
+ [install-statement Statement #statement cannot-define-statement-more-than-once]
+ )
diff --git a/stdlib/source/lux/lang/extension/analysis.lux b/stdlib/source/lux/lang/extension/analysis.lux
new file mode 100644
index 000000000..40fd84679
--- /dev/null
+++ b/stdlib/source/lux/lang/extension/analysis.lux
@@ -0,0 +1,16 @@
+(.module:
+ lux
+ (lux (data [text]
+ (coll [list "list/" Functor<List>]
+ (dictionary ["dict" unordered #+ Dict]))))
+ [//]
+ [/common]
+ [/host])
+
+(def: #export defaults
+ (//.Extension //.Analysis)
+ (|> /common.specials
+ (dict.merge /host.specials)
+ dict.entries
+ (list/map (function (_ [name proc]) [name (proc name)]))
+ (dict.from-list text.Hash<Text>)))
diff --git a/stdlib/source/lux/lang/extension/analysis/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux
new file mode 100644
index 000000000..8c0116721
--- /dev/null
+++ b/stdlib/source/lux/lang/extension/analysis/common.lux
@@ -0,0 +1,444 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
+ [thread])
+ (concurrency [atom #+ Atom])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor<List>]
+ [array]
+ (dictionary ["dict" unordered #+ Dict])))
+ [macro]
+ (macro [code])
+ [lang]
+ (lang (type ["tc" check])
+ [".L" analysis]
+ (analysis [".A" type]
+ [".A" case]
+ [".A" function]))
+ [io])
+ [///])
+
+(exception: #export (incorrect-special-arity {name Text} {arity Nat} {args Nat})
+ (ex.report ["Special" (%t name)]
+ ["Expected arity" (|> arity .int %i)]
+ ["Actual arity" (|> args .int %i)]))
+
+(exception: #export (invalid-syntax {name Text} {arguments (List Code)})
+ (ex.report ["Special" name]
+ ["Inputs" (|> arguments
+ list.enumerate
+ (list/map (function (_ [idx argC])
+ (format "\n " (%n idx) " " (%code argC))))
+ (text.join-with ""))]))
+
+## [Utils]
+(type: #export Bundle
+ (Dict Text (-> Text ///.Analysis)))
+
+(def: #export (install name unnamed)
+ (-> Text (-> Text ///.Analysis)
+ (-> Bundle Bundle))
+ (dict.put name unnamed))
+
+(def: #export (prefix prefix bundle)
+ (-> Text Bundle Bundle)
+ (|> bundle
+ dict.entries
+ (list/map (function (_ [key val]) [(format prefix " " key) val]))
+ (dict.from-list text.Hash<Text>)))
+
+(def: (simple proc inputsT+ outputT)
+ (-> Text (List Type) Type ///.Analysis)
+ (let [num-expected (list.size inputsT+)]
+ (function (_ analyse eval args)
+ (let [num-actual (list.size args)]
+ (if (n/= num-expected num-actual)
+ (do macro.Monad<Meta>
+ [_ (typeA.infer outputT)
+ argsA (monad.map @
+ (function (_ [argT argC])
+ (typeA.with-type argT
+ (analyse argC)))
+ (list.zip2 inputsT+ args))]
+ (wrap (#analysisL.Special proc argsA)))
+ (lang.throw incorrect-special-arity [proc num-expected num-actual]))))))
+
+(def: #export (nullary valueT proc)
+ (-> Type Text ///.Analysis)
+ (simple proc (list) valueT))
+
+(def: #export (unary inputT outputT proc)
+ (-> Type Type Text ///.Analysis)
+ (simple proc (list inputT) outputT))
+
+(def: #export (binary subjectT paramT outputT proc)
+ (-> Type Type Type Text ///.Analysis)
+ (simple proc (list subjectT paramT) outputT))
+
+(def: #export (trinary subjectT param0T param1T outputT proc)
+ (-> Type Type Type Type Text ///.Analysis)
+ (simple proc (list subjectT param0T param1T) outputT))
+
+## [Analysers]
+## "lux is" represents reference/pointer equality.
+(def: (lux//is proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((binary varT varT Bool proc)
+ analyse eval args))))
+
+## "lux try" provides a simple way to interact with the host platform's
+## error-handling facilities.
+(def: (lux//try proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list opC))
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Either Text varT)))
+ opA (typeA.with-type (type (io.IO varT))
+ (analyse opC))]
+ (wrap (#analysisL.Special proc (list opA))))
+
+ _
+ (lang.throw incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (lux//function proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list [_ (#.Symbol ["" func-name])]
+ [_ (#.Symbol ["" arg-name])]
+ body))
+ (functionA.function analyse func-name arg-name body)
+
+ _
+ (lang.throw incorrect-special-arity [proc +3 (list.size args)]))))
+
+(def: (lux//case proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list input [_ (#.Record branches)]))
+ (caseA.case analyse input branches)
+
+ _
+ (lang.throw incorrect-special-arity [proc +2 (list.size args)]))))
+
+(def: (lux//in-module proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval argsC+)
+ (case argsC+
+ (^ (list [_ (#.Text module-name)] exprC))
+ (lang.with-current-module module-name
+ (analyse exprC))
+
+ _
+ (lang.throw invalid-syntax [proc argsC+]))))
+
+(do-template [<name> <type>]
+ [(def: (<name> proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list typeC valueC))
+ (do macro.Monad<Meta>
+ [actualT (eval Type typeC)
+ _ (typeA.infer (:! Type actualT))]
+ (typeA.with-type <type>
+ (analyse valueC)))
+
+ _
+ (lang.throw incorrect-special-arity [proc +2 (list.size args)]))))]
+
+ [lux//check (:! Type actualT)]
+ [lux//coerce Any]
+ )
+
+(def: (lux//check//type proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list valueC))
+ (do macro.Monad<Meta>
+ [_ (typeA.infer Type)
+ valueA (typeA.with-type Type
+ (analyse valueC))]
+ (wrap valueA))
+
+ _
+ (lang.throw incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: lux-procs
+ Bundle
+ (|> (dict.new text.Hash<Text>)
+ (install "is" lux//is)
+ (install "try" lux//try)
+ (install "function" lux//function)
+ (install "case" lux//case)
+ (install "check" lux//check)
+ (install "coerce" lux//coerce)
+ (install "check type" lux//check//type)
+ (install "in-module" lux//in-module)))
+
+(def: io-procs
+ Bundle
+ (<| (prefix "io")
+ (|> (dict.new text.Hash<Text>)
+ (install "log" (unary Text Any))
+ (install "error" (unary Text Nothing))
+ (install "exit" (unary Int Nothing))
+ (install "current-time" (nullary Int)))))
+
+(def: bit-procs
+ Bundle
+ (<| (prefix "bit")
+ (|> (dict.new text.Hash<Text>)
+ (install "and" (binary Nat Nat Nat))
+ (install "or" (binary Nat Nat Nat))
+ (install "xor" (binary Nat Nat Nat))
+ (install "left-shift" (binary Nat Nat Nat))
+ (install "logical-right-shift" (binary Nat Nat Nat))
+ (install "arithmetic-right-shift" (binary Int Nat Int))
+ )))
+
+(def: int-procs
+ Bundle
+ (<| (prefix "int")
+ (|> (dict.new text.Hash<Text>)
+ (install "+" (binary Int Int Int))
+ (install "-" (binary Int Int Int))
+ (install "*" (binary Int Int Int))
+ (install "/" (binary Int Int Int))
+ (install "%" (binary Int Int Int))
+ (install "=" (binary Int Int Bool))
+ (install "<" (binary Int Int Bool))
+ (install "min" (nullary Int))
+ (install "max" (nullary Int))
+ (install "to-nat" (unary Int Nat))
+ (install "to-frac" (unary Int Frac))
+ (install "char" (unary Int Text)))))
+
+(def: deg-procs
+ Bundle
+ (<| (prefix "deg")
+ (|> (dict.new text.Hash<Text>)
+ (install "+" (binary Deg Deg Deg))
+ (install "-" (binary Deg Deg Deg))
+ (install "*" (binary Deg Deg Deg))
+ (install "/" (binary Deg Deg Deg))
+ (install "%" (binary Deg Deg Deg))
+ (install "=" (binary Deg Deg Bool))
+ (install "<" (binary Deg Deg Bool))
+ (install "scale" (binary Deg Nat Deg))
+ (install "reciprocal" (binary Deg Nat Deg))
+ (install "min" (nullary Deg))
+ (install "max" (nullary Deg))
+ (install "to-frac" (unary Deg Frac)))))
+
+(def: frac-procs
+ Bundle
+ (<| (prefix "frac")
+ (|> (dict.new text.Hash<Text>)
+ (install "+" (binary Frac Frac Frac))
+ (install "-" (binary Frac Frac Frac))
+ (install "*" (binary Frac Frac Frac))
+ (install "/" (binary Frac Frac Frac))
+ (install "%" (binary Frac Frac Frac))
+ (install "=" (binary Frac Frac Bool))
+ (install "<" (binary Frac Frac Bool))
+ (install "smallest" (nullary Frac))
+ (install "min" (nullary Frac))
+ (install "max" (nullary Frac))
+ (install "not-a-number" (nullary Frac))
+ (install "positive-infinity" (nullary Frac))
+ (install "negative-infinity" (nullary Frac))
+ (install "to-deg" (unary Frac Deg))
+ (install "to-int" (unary Frac Int))
+ (install "encode" (unary Frac Text))
+ (install "decode" (unary Text (type (Maybe Frac)))))))
+
+(def: text-procs
+ Bundle
+ (<| (prefix "text")
+ (|> (dict.new text.Hash<Text>)
+ (install "=" (binary Text Text Bool))
+ (install "<" (binary Text Text Bool))
+ (install "concat" (binary Text Text Text))
+ (install "index" (trinary Text Text Nat (type (Maybe Nat))))
+ (install "size" (unary Text Nat))
+ (install "hash" (unary Text Nat))
+ (install "replace-once" (trinary Text Text Text Text))
+ (install "replace-all" (trinary Text Text Text Text))
+ (install "char" (binary Text Nat (type (Maybe Nat))))
+ (install "clip" (trinary Text Nat Nat (type (Maybe Text))))
+ )))
+
+(def: (array//get proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
+ analyse eval args))))
+
+(def: (array//put proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
+ analyse eval args))))
+
+(def: (array//remove proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((binary (type (Array varT)) Nat (type (Array varT)) proc)
+ analyse eval args))))
+
+(def: array-procs
+ Bundle
+ (<| (prefix "array")
+ (|> (dict.new text.Hash<Text>)
+ (install "new" (unary Nat Array))
+ (install "get" array//get)
+ (install "put" array//put)
+ (install "remove" array//remove)
+ (install "size" (unary (type (Ex [a] (Array a))) Nat))
+ )))
+
+(def: math-procs
+ Bundle
+ (<| (prefix "math")
+ (|> (dict.new text.Hash<Text>)
+ (install "cos" (unary Frac Frac))
+ (install "sin" (unary Frac Frac))
+ (install "tan" (unary Frac Frac))
+ (install "acos" (unary Frac Frac))
+ (install "asin" (unary Frac Frac))
+ (install "atan" (unary Frac Frac))
+ (install "cosh" (unary Frac Frac))
+ (install "sinh" (unary Frac Frac))
+ (install "tanh" (unary Frac Frac))
+ (install "exp" (unary Frac Frac))
+ (install "log" (unary Frac Frac))
+ (install "ceil" (unary Frac Frac))
+ (install "floor" (unary Frac Frac))
+ (install "round" (unary Frac Frac))
+ (install "atan2" (binary Frac Frac Frac))
+ (install "pow" (binary Frac Frac Frac))
+ )))
+
+(def: (atom-new proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list initC))
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Atom varT)))
+ initA (typeA.with-type varT
+ (analyse initC))]
+ (wrap (#analysisL.Special proc (list initA))))
+
+ _
+ (lang.throw incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (atom-read proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((unary (type (Atom varT)) varT proc)
+ analyse eval args))))
+
+(def: (atom//compare-and-swap proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((trinary (type (Atom varT)) varT varT Bool proc)
+ analyse eval args))))
+
+(def: atom-procs
+ Bundle
+ (<| (prefix "atom")
+ (|> (dict.new text.Hash<Text>)
+ (install "new" atom-new)
+ (install "read" atom-read)
+ (install "compare-and-swap" atom//compare-and-swap)
+ )))
+
+(def: (box//new proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list initC))
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (All [!] (thread.Box ! varT))))
+ initA (typeA.with-type varT
+ (analyse initC))]
+ (wrap (#analysisL.Special proc (list initA))))
+
+ _
+ (lang.throw incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (box//read proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[thread-id threadT] (typeA.with-env tc.var)
+ [var-id varT] (typeA.with-env tc.var)]
+ ((unary (type (thread.Box threadT varT)) varT proc)
+ analyse eval args))))
+
+(def: (box//write proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (do macro.Monad<Meta>
+ [[thread-id threadT] (typeA.with-env tc.var)
+ [var-id varT] (typeA.with-env tc.var)]
+ ((binary varT (type (thread.Box threadT varT)) Any proc)
+ analyse eval args))))
+
+(def: box-procs
+ Bundle
+ (<| (prefix "box")
+ (|> (dict.new text.Hash<Text>)
+ (install "new" box//new)
+ (install "read" box//read)
+ (install "write" box//write)
+ )))
+
+(def: process-procs
+ Bundle
+ (<| (prefix "process")
+ (|> (dict.new text.Hash<Text>)
+ (install "parallelism-level" (nullary Nat))
+ (install "schedule" (binary Nat (type (io.IO Any)) Any))
+ )))
+
+(def: #export specials
+ Bundle
+ (<| (prefix "lux")
+ (|> (dict.new text.Hash<Text>)
+ (dict.merge lux-procs)
+ (dict.merge bit-procs)
+ (dict.merge int-procs)
+ (dict.merge deg-procs)
+ (dict.merge frac-procs)
+ (dict.merge text-procs)
+ (dict.merge array-procs)
+ (dict.merge math-procs)
+ (dict.merge atom-procs)
+ (dict.merge box-procs)
+ (dict.merge process-procs)
+ (dict.merge io-procs))))
diff --git a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux
new file mode 100644
index 000000000..31b811fac
--- /dev/null
+++ b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux
@@ -0,0 +1,1224 @@
+(.module:
+ [lux #- char int]
+ (lux (control [monad #+ do]
+ ["p" parser]
+ ["ex" exception #+ exception:])
+ (concurrency ["A" atom])
+ (data ["e" error]
+ [maybe]
+ [product]
+ [bool "bool/" Eq<Bool>]
+ [text "text/" Eq<Text>]
+ (text format
+ ["l" lexer])
+ (coll [list "list/" Fold<List> Functor<List> Monoid<List>]
+ [array]
+ (dictionary ["dict" unordered #+ Dict])))
+ [macro "macro/" Monad<Meta>]
+ (macro [code]
+ ["s" syntax])
+ [lang]
+ (lang [type]
+ (type ["tc" check])
+ [".L" analysis #+ Analysis]
+ (analysis [".A" type]
+ [".A" inference]))
+ [host])
+ ["/" //common]
+ [///]
+ )
+
+(host.import #long java/lang/reflect/Type
+ (getTypeName [] String))
+
+(def: jvm-type-name
+ (-> java/lang/reflect/Type Text)
+ (java/lang/reflect/Type::getTypeName []))
+
+(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type})
+ (jvm-type-name jvm-type))
+
+(do-template [<name>]
+ [(exception: #export (<name> {type Type})
+ (%type type))]
+
+ [non-object]
+ [non-array]
+ [non-jvm-type]
+ )
+
+(do-template [<name>]
+ [(exception: #export (<name> {name Text})
+ name)]
+
+ [non-interface]
+ [non-throwable]
+ )
+
+(do-template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
+
+ [Unknown-Class]
+ [Primitives-Cannot-Have-Type-Parameters]
+ [Primitives-Are-Not-Objects]
+ [Invalid-Type-For-Array-Element]
+
+ [Unknown-Field]
+ [Mistaken-Field-Owner]
+ [Not-Virtual-Field]
+ [Not-Static-Field]
+ [Cannot-Set-Final-Field]
+
+ [No-Candidates]
+ [Too-Many-Candidates]
+
+ [Cannot-Cast]
+
+ [Cannot-Possibly-Be-Instance]
+
+ [Cannot-Convert-To-Class]
+ [Cannot-Convert-To-Parameter]
+ [Cannot-Convert-To-Lux-Type]
+ [Unknown-Type-Var]
+ [Type-Parameter-Mismatch]
+ [Cannot-Correspond-Type-With-Class]
+ )
+
+(do-template [<name> <class>]
+ [(def: #export <name> Type (#.Primitive <class> (list)))]
+
+ ## Boxes
+ [Boolean "java.lang.Boolean"]
+ [Byte "java.lang.Byte"]
+ [Short "java.lang.Short"]
+ [Integer "java.lang.Integer"]
+ [Long "java.lang.Long"]
+ [Float "java.lang.Float"]
+ [Double "java.lang.Double"]
+ [Character "java.lang.Character"]
+ [String "java.lang.String"]
+
+ ## Primitives
+ [boolean "boolean"]
+ [byte "byte"]
+ [short "short"]
+ [int "int"]
+ [long "long"]
+ [float "float"]
+ [double "double"]
+ [char "char"]
+ )
+
+(def: conversion-procs
+ /.Bundle
+ (<| (/.prefix "convert")
+ (|> (dict.new text.Hash<Text>)
+ (/.install "double-to-float" (/.unary Double Float))
+ (/.install "double-to-int" (/.unary Double Integer))
+ (/.install "double-to-long" (/.unary Double Long))
+ (/.install "float-to-double" (/.unary Float Double))
+ (/.install "float-to-int" (/.unary Float Integer))
+ (/.install "float-to-long" (/.unary Float Long))
+ (/.install "int-to-byte" (/.unary Integer Byte))
+ (/.install "int-to-char" (/.unary Integer Character))
+ (/.install "int-to-double" (/.unary Integer Double))
+ (/.install "int-to-float" (/.unary Integer Float))
+ (/.install "int-to-long" (/.unary Integer Long))
+ (/.install "int-to-short" (/.unary Integer Short))
+ (/.install "long-to-double" (/.unary Long Double))
+ (/.install "long-to-float" (/.unary Long Float))
+ (/.install "long-to-int" (/.unary Long Integer))
+ (/.install "long-to-short" (/.unary Long Short))
+ (/.install "long-to-byte" (/.unary Long Byte))
+ (/.install "char-to-byte" (/.unary Character Byte))
+ (/.install "char-to-short" (/.unary Character Short))
+ (/.install "char-to-int" (/.unary Character Integer))
+ (/.install "char-to-long" (/.unary Character Long))
+ (/.install "byte-to-long" (/.unary Byte Long))
+ (/.install "short-to-long" (/.unary Short Long))
+ )))
+
+(do-template [<name> <prefix> <type>]
+ [(def: <name>
+ /.Bundle
+ (<| (/.prefix <prefix>)
+ (|> (dict.new text.Hash<Text>)
+ (/.install "+" (/.binary <type> <type> <type>))
+ (/.install "-" (/.binary <type> <type> <type>))
+ (/.install "*" (/.binary <type> <type> <type>))
+ (/.install "/" (/.binary <type> <type> <type>))
+ (/.install "%" (/.binary <type> <type> <type>))
+ (/.install "=" (/.binary <type> <type> Boolean))
+ (/.install "<" (/.binary <type> <type> Boolean))
+ (/.install "and" (/.binary <type> <type> <type>))
+ (/.install "or" (/.binary <type> <type> <type>))
+ (/.install "xor" (/.binary <type> <type> <type>))
+ (/.install "shl" (/.binary <type> Integer <type>))
+ (/.install "shr" (/.binary <type> Integer <type>))
+ (/.install "ushr" (/.binary <type> Integer <type>))
+ )))]
+
+ [int-procs "int" Integer]
+ [long-procs "long" Long]
+ )
+
+(do-template [<name> <prefix> <type>]
+ [(def: <name>
+ /.Bundle
+ (<| (/.prefix <prefix>)
+ (|> (dict.new text.Hash<Text>)
+ (/.install "+" (/.binary <type> <type> <type>))
+ (/.install "-" (/.binary <type> <type> <type>))
+ (/.install "*" (/.binary <type> <type> <type>))
+ (/.install "/" (/.binary <type> <type> <type>))
+ (/.install "%" (/.binary <type> <type> <type>))
+ (/.install "=" (/.binary <type> <type> Boolean))
+ (/.install "<" (/.binary <type> <type> Boolean))
+ )))]
+
+ [float-procs "float" Float]
+ [double-procs "double" Double]
+ )
+
+(def: char-procs
+ /.Bundle
+ (<| (/.prefix "char")
+ (|> (dict.new text.Hash<Text>)
+ (/.install "=" (/.binary Character Character Boolean))
+ (/.install "<" (/.binary Character Character Boolean))
+ )))
+
+(def: #export boxes
+ (Dict Text Text)
+ (|> (list ["boolean" "java.lang.Boolean"]
+ ["byte" "java.lang.Byte"]
+ ["short" "java.lang.Short"]
+ ["int" "java.lang.Integer"]
+ ["long" "java.lang.Long"]
+ ["float" "java.lang.Float"]
+ ["double" "java.lang.Double"]
+ ["char" "java.lang.Character"])
+ (dict.from-list text.Hash<Text>)))
+
+(def: (array//length proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list arrayC))
+ (do macro.Monad<Meta>
+ [_ (typeA.infer Nat)
+ [var-id varT] (typeA.with-env tc.var)
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))]
+ (wrap (#analysisL.Special proc (list arrayA))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (array//new proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list lengthC))
+ (do macro.Monad<Meta>
+ [lengthA (typeA.with-type Nat
+ (analyse lengthC))
+ expectedT macro.expected-type
+ [level elem-class] (: (Meta [Nat Text])
+ (loop [analysisT expectedT
+ level +0]
+ (case analysisT
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (recur outputT level)
+
+ #.None
+ (lang.throw non-array expectedT))
+
+ (^ (#.Primitive "#Array" (list elemT)))
+ (recur elemT (inc level))
+
+ (#.Primitive class _)
+ (wrap [level class])
+
+ _
+ (lang.throw non-array expectedT))))
+ _ (if (n/> +0 level)
+ (wrap [])
+ (lang.throw non-array expectedT))]
+ (wrap (#analysisL.Special proc (list (analysisL.nat (dec level))
+ (analysisL.text elem-class)
+ lengthA))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (check-jvm objectT)
+ (-> Type (Meta Text))
+ (case objectT
+ (#.Primitive name _)
+ (macro/wrap name)
+
+ (#.Named name unnamed)
+ (check-jvm unnamed)
+
+ (#.Var id)
+ (macro/wrap "java.lang.Object")
+
+ (^template [<tag>]
+ (<tag> env unquantified)
+ (check-jvm unquantified))
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (check-jvm outputT)
+
+ #.None
+ (lang.throw non-object objectT))
+
+ _
+ (lang.throw non-object objectT)))
+
+(def: (check-object objectT)
+ (-> Type (Meta Text))
+ (do macro.Monad<Meta>
+ [name (check-jvm objectT)]
+ (if (dict.contains? name boxes)
+ (lang.throw Primitives-Are-Not-Objects name)
+ (macro/wrap name))))
+
+(def: (box-array-element-type elemT)
+ (-> Type (Meta [Type Text]))
+ (case elemT
+ (#.Primitive name #.Nil)
+ (let [boxed-name (|> (dict.get name boxes)
+ (maybe.default name))]
+ (macro/wrap [(#.Primitive boxed-name #.Nil)
+ boxed-name]))
+
+ (#.Primitive name _)
+ (if (dict.contains? name boxes)
+ (lang.throw Primitives-Cannot-Have-Type-Parameters name)
+ (macro/wrap [elemT name]))
+
+ _
+ (lang.throw Invalid-Type-For-Array-Element (%type elemT))))
+
+(def: (array//read proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list arrayC idxC))
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer varT)
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))
+ ?elemT (typeA.with-env
+ (tc.read var-id))
+ [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (typeA.with-type Nat
+ (analyse idxC))]
+ (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA arrayA))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +2 (list.size args)]))))
+
+(def: (array//write proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list arrayC idxC valueC))
+ (do macro.Monad<Meta>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Array varT)))
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))
+ ?elemT (typeA.with-env
+ (tc.read var-id))
+ [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (typeA.with-type Nat
+ (analyse idxC))
+ valueA (typeA.with-type valueT
+ (analyse valueC))]
+ (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA valueA arrayA))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +3 (list.size args)]))))
+
+(def: array-procs
+ /.Bundle
+ (<| (/.prefix "array")
+ (|> (dict.new text.Hash<Text>)
+ (/.install "length" array//length)
+ (/.install "new" array//new)
+ (/.install "read" array//read)
+ (/.install "write" array//write)
+ )))
+
+(def: (object//null proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list))
+ (do macro.Monad<Meta>
+ [expectedT macro.expected-type
+ _ (check-object expectedT)]
+ (wrap (#analysisL.Special proc (list))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +0 (list.size args)]))))
+
+(def: (object//null? proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list objectC))
+ (do macro.Monad<Meta>
+ [_ (typeA.infer Bool)
+ [objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ _ (check-object objectT)]
+ (wrap (#analysisL.Special proc (list objectA))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (object//synchronized proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list monitorC exprC))
+ (do macro.Monad<Meta>
+ [[monitorT monitorA] (typeA.with-inference
+ (analyse monitorC))
+ _ (check-object monitorT)
+ exprA (analyse exprC)]
+ (wrap (#analysisL.Special proc (list monitorA exprA))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +2 (list.size args)]))))
+
+(host.import java/lang/Object
+ (equals [Object] boolean))
+
+(host.import java/lang/ClassLoader)
+
+(host.import java/lang/reflect/GenericArrayType
+ (getGenericComponentType [] java/lang/reflect/Type))
+
+(host.import java/lang/reflect/ParameterizedType
+ (getRawType [] java/lang/reflect/Type)
+ (getActualTypeArguments [] (Array java/lang/reflect/Type)))
+
+(host.import (java/lang/reflect/TypeVariable d)
+ (getName [] String)
+ (getBounds [] (Array java/lang/reflect/Type)))
+
+(host.import (java/lang/reflect/WildcardType d)
+ (getLowerBounds [] (Array java/lang/reflect/Type))
+ (getUpperBounds [] (Array java/lang/reflect/Type)))
+
+(host.import java/lang/reflect/Modifier
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean)
+ (#static isInterface [int] boolean)
+ (#static isAbstract [int] boolean))
+
+(host.import java/lang/reflect/Field
+ (getDeclaringClass [] (java/lang/Class Object))
+ (getModifiers [] int)
+ (getGenericType [] java/lang/reflect/Type))
+
+(host.import java/lang/reflect/Method
+ (getName [] String)
+ (getModifiers [] int)
+ (getDeclaringClass [] (Class Object))
+ (getTypeParameters [] (Array (TypeVariable Method)))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericReturnType [] java/lang/reflect/Type)
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
+
+(host.import (java/lang/reflect/Constructor c)
+ (getModifiers [] int)
+ (getDeclaringClass [] (Class c))
+ (getTypeParameters [] (Array (TypeVariable (Constructor c))))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
+
+(host.import (java/lang/Class c)
+ (getName [] String)
+ (getModifiers [] int)
+ (#static forName [String] #try (Class Object))
+ (isAssignableFrom [(Class Object)] boolean)
+ (getTypeParameters [] (Array (TypeVariable (Class c))))
+ (getGenericInterfaces [] (Array java/lang/reflect/Type))
+ (getGenericSuperclass [] java/lang/reflect/Type)
+ (getDeclaredField [String] #try Field)
+ (getConstructors [] (Array (Constructor Object)))
+ (getDeclaredMethods [] (Array Method)))
+
+(def: (load-class name)
+ (-> Text (Meta (Class Object)))
+ (do macro.Monad<Meta>
+ []
+ (case (Class::forName [name])
+ (#e.Success [class])
+ (wrap class)
+
+ (#e.Error error)
+ (lang.throw Unknown-Class name))))
+
+(def: (sub-class? super sub)
+ (-> Text Text (Meta Bool))
+ (do macro.Monad<Meta>
+ [super (load-class super)
+ sub (load-class sub)]
+ (wrap (Class::isAssignableFrom [sub] super))))
+
+(def: (object//throw proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list exceptionC))
+ (do macro.Monad<Meta>
+ [_ (typeA.infer Nothing)
+ [exceptionT exceptionA] (typeA.with-inference
+ (analyse exceptionC))
+ exception-class (check-object exceptionT)
+ ? (sub-class? "java.lang.Throwable" exception-class)
+ _ (: (Meta Any)
+ (if ?
+ (wrap [])
+ (lang.throw non-throwable exception-class)))]
+ (wrap (#analysisL.Special proc (list exceptionA))))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (object//class proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list classC))
+ (case classC
+ [_ (#.Text class)]
+ (do macro.Monad<Meta>
+ [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
+ _ (load-class class)]
+ (wrap (#analysisL.Special proc (list (analysisL.text class)))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +1 (list.size args)]))))
+
+(def: (object//instance? proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list classC objectC))
+ (case classC
+ [_ (#.Text class)]
+ (do macro.Monad<Meta>
+ [_ (typeA.infer Bool)
+ [objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ object-class (check-object objectT)
+ ? (sub-class? class object-class)]
+ (if ?
+ (wrap (#analysisL.Special proc (list (analysisL.text class))))
+ (lang.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +2 (list.size args)]))))
+
+(def: (java-type-to-class type)
+ (-> java/lang/reflect/Type (Meta Text))
+ (cond (host.instance? Class type)
+ (macro/wrap (Class::getName [] (:! Class type)))
+
+ (host.instance? ParameterizedType type)
+ (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type)))
+
+ ## else
+ (lang.throw Cannot-Convert-To-Class (jvm-type-name type))))
+
+(type: Mappings
+ (Dict Text Type))
+
+(def: fresh-mappings Mappings (dict.new text.Hash<Text>))
+
+(def: (java-type-to-lux-type mappings java-type)
+ (-> Mappings java/lang/reflect/Type (Meta Type))
+ (cond (host.instance? TypeVariable java-type)
+ (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))]
+ (case (dict.get var-name mappings)
+ (#.Some var-type)
+ (macro/wrap var-type)
+
+ #.None
+ (lang.throw Unknown-Type-Var var-name)))
+
+ (host.instance? WildcardType java-type)
+ (let [java-type (:! WildcardType java-type)]
+ (case [(array.read +0 (WildcardType::getUpperBounds [] java-type))
+ (array.read +0 (WildcardType::getLowerBounds [] java-type))]
+ (^or [(#.Some bound) _] [_ (#.Some bound)])
+ (java-type-to-lux-type mappings bound)
+
+ _
+ (macro/wrap Any)))
+
+ (host.instance? Class java-type)
+ (let [java-type (:! (Class Object) java-type)
+ class-name (Class::getName [] java-type)]
+ (macro/wrap (case (array.size (Class::getTypeParameters [] java-type))
+ +0
+ (#.Primitive class-name (list))
+
+ arity
+ (|> (list.n/range +0 (dec arity))
+ list.reverse
+ (list/map (|>> (n/* +2) inc #.Bound))
+ (#.Primitive class-name)
+ (type.univ-q arity)))))
+
+ (host.instance? ParameterizedType java-type)
+ (let [java-type (:! ParameterizedType java-type)
+ raw (ParameterizedType::getRawType [] java-type)]
+ (if (host.instance? Class raw)
+ (do macro.Monad<Meta>
+ [paramsT (|> java-type
+ (ParameterizedType::getActualTypeArguments [])
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))]
+ (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw))
+ paramsT)))
+ (lang.throw jvm-type-is-not-a-class raw)))
+
+ (host.instance? GenericArrayType java-type)
+ (do macro.Monad<Meta>
+ [innerT (|> (:! GenericArrayType java-type)
+ (GenericArrayType::getGenericComponentType [])
+ (java-type-to-lux-type mappings))]
+ (wrap (#.Primitive "#Array" (list innerT))))
+
+ ## else
+ (lang.throw Cannot-Convert-To-Lux-Type (jvm-type-name java-type))))
+
+(def: (correspond-type-params class type)
+ (-> (Class Object) Type (Meta Mappings))
+ (case type
+ (#.Primitive name params)
+ (let [class-name (Class::getName [] class)
+ class-params (array.to-list (Class::getTypeParameters [] class))
+ num-class-params (list.size class-params)
+ num-type-params (list.size params)]
+ (cond (not (text/= class-name name))
+ (lang.throw Cannot-Correspond-Type-With-Class
+ (format "Class = " class-name "\n"
+ "Type = " (%type type)))
+
+ (not (n/= num-class-params num-type-params))
+ (lang.throw Type-Parameter-Mismatch
+ (format "Expected: " (%i (.int num-class-params)) "\n"
+ " Actual: " (%i (.int num-type-params)) "\n"
+ " Class: " class-name "\n"
+ " Type: " (%type type)))
+
+ ## else
+ (macro/wrap (|> params
+ (list.zip2 (list/map (TypeVariable::getName []) class-params))
+ (dict.from-list text.Hash<Text>)))
+ ))
+
+ _
+ (lang.throw non-jvm-type type)))
+
+(def: (object//cast proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list valueC))
+ (do macro.Monad<Meta>
+ [toT macro.expected-type
+ to-name (check-jvm toT)
+ [valueT valueA] (typeA.with-inference
+ (analyse valueC))
+ from-name (check-jvm valueT)
+ can-cast? (: (Meta Bool)
+ (case [from-name to-name]
+ (^template [<primitive> <object>]
+ (^or [<primitive> <object>]
+ [<object> <primitive>])
+ (do @
+ [_ (typeA.infer (#.Primitive to-name (list)))]
+ (wrap true)))
+ (["boolean" "java.lang.Boolean"]
+ ["byte" "java.lang.Byte"]
+ ["short" "java.lang.Short"]
+ ["int" "java.lang.Integer"]
+ ["long" "java.lang.Long"]
+ ["float" "java.lang.Float"]
+ ["double" "java.lang.Double"]
+ ["char" "java.lang.Character"])
+
+ _
+ (do @
+ [_ (lang.assert Primitives-Are-Not-Objects from-name
+ (not (dict.contains? from-name boxes)))
+ _ (lang.assert Primitives-Are-Not-Objects to-name
+ (not (dict.contains? to-name boxes)))
+ to-class (load-class to-name)]
+ (loop [[current-name currentT] [from-name valueT]]
+ (if (text/= to-name current-name)
+ (do @
+ [_ (typeA.infer toT)]
+ (wrap true))
+ (do @
+ [current-class (load-class current-name)
+ _ (lang.assert Cannot-Cast (format "From class/primitive: " current-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")
+ (Class::isAssignableFrom [current-class] to-class))
+ candiate-parents (monad.map @
+ (function (_ java-type)
+ (do @
+ [class-name (java-type-to-class java-type)
+ class (load-class class-name)]
+ (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)])))
+ (list& (Class::getGenericSuperclass [] current-class)
+ (array.to-list (Class::getGenericInterfaces [] current-class))))]
+ (case (|> candiate-parents
+ (list.filter product.right)
+ (list/map product.left))
+ (#.Cons [next-name nextJT] _)
+ (do @
+ [mapping (correspond-type-params current-class currentT)
+ nextT (java-type-to-lux-type mapping nextJT)]
+ (recur [next-name nextT]))
+
+ #.Nil
+ (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")))
+ ))))))]
+ (if can-cast?
+ (wrap (#analysisL.Special proc (list (analysisL.text from-name)
+ (analysisL.text to-name)
+ valueA)))
+ (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n"))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))))
+
+(def: object-procs
+ /.Bundle
+ (<| (/.prefix "object")
+ (|> (dict.new text.Hash<Text>)
+ (/.install "null" object//null)
+ (/.install "null?" object//null?)
+ (/.install "synchronized" object//synchronized)
+ (/.install "throw" object//throw)
+ (/.install "class" object//class)
+ (/.install "instance?" object//instance?)
+ (/.install "cast" object//cast)
+ )))
+
+(def: (find-field class-name field-name)
+ (-> Text Text (Meta [(Class Object) Field]))
+ (do macro.Monad<Meta>
+ [class (load-class class-name)]
+ (case (Class::getDeclaredField [field-name] class)
+ (#e.Success field)
+ (let [owner (Field::getDeclaringClass [] field)]
+ (if (is? owner class)
+ (wrap [class field])
+ (lang.throw Mistaken-Field-Owner
+ (format " Field: " field-name "\n"
+ " Owner Class: " (Class::getName [] owner) "\n"
+ "Target Class: " class-name "\n"))))
+
+ (#e.Error _)
+ (lang.throw Unknown-Field (format class-name "#" field-name)))))
+
+(def: (static-field class-name field-name)
+ (-> Text Text (Meta [Type Bool]))
+ (do macro.Monad<Meta>
+ [[class fieldJ] (find-field class-name field-name)
+ #let [modifiers (Field::getModifiers [] fieldJ)]]
+ (if (Modifier::isStatic [modifiers])
+ (let [fieldJT (Field::getGenericType [] fieldJ)]
+ (do @
+ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)]
+ (wrap [fieldT (Modifier::isFinal [modifiers])])))
+ (lang.throw Not-Static-Field (format class-name "#" field-name)))))
+
+(def: (virtual-field class-name field-name objectT)
+ (-> Text Text Type (Meta [Type Bool]))
+ (do macro.Monad<Meta>
+ [[class fieldJ] (find-field class-name field-name)
+ #let [modifiers (Field::getModifiers [] fieldJ)]]
+ (if (not (Modifier::isStatic [modifiers]))
+ (do @
+ [#let [fieldJT (Field::getGenericType [] fieldJ)
+ var-names (|> class
+ (Class::getTypeParameters [])
+ array.to-list
+ (list/map (TypeVariable::getName [])))]
+ mappings (: (Meta Mappings)
+ (case objectT
+ (#.Primitive _class-name _class-params)
+ (do @
+ [#let [num-params (list.size _class-params)
+ num-vars (list.size var-names)]
+ _ (lang.assert Type-Parameter-Mismatch
+ (format "Expected: " (%i (.int num-params)) "\n"
+ " Actual: " (%i (.int num-vars)) "\n"
+ " Class: " _class-name "\n"
+ " Type: " (%type objectT))
+ (n/= num-params num-vars))]
+ (wrap (|> (list.zip2 var-names _class-params)
+ (dict.from-list text.Hash<Text>))))
+
+ _
+ (lang.throw non-object objectT)))
+ fieldT (java-type-to-lux-type mappings fieldJT)]
+ (wrap [fieldT (Modifier::isFinal [modifiers])]))
+ (lang.throw Not-Virtual-Field (format class-name "#" field-name)))))
+
+(def: (static//get proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list classC fieldC))
+ (case [classC fieldC]
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad<Meta>
+ [[fieldT final?] (static-field class field)]
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field)))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +2 (list.size args)]))))
+
+(def: (static//put proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list classC fieldC valueC))
+ (case [classC fieldC]
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad<Meta>
+ [_ (typeA.infer Any)
+ [fieldT final?] (static-field class field)
+ _ (lang.assert Cannot-Set-Final-Field (format class "#" field)
+ (not final?))
+ valueA (typeA.with-type fieldT
+ (analyse valueC))]
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +3 (list.size args)]))))
+
+(def: (virtual//get proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list classC fieldC objectC))
+ (case [classC fieldC]
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad<Meta>
+ [[objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ [fieldT final?] (virtual-field class field objectT)]
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) objectA))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +3 (list.size args)]))))
+
+(def: (virtual//put proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case args
+ (^ (list classC fieldC valueC objectC))
+ (case [classC fieldC]
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad<Meta>
+ [[objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ _ (typeA.infer objectT)
+ [fieldT final?] (virtual-field class field objectT)
+ _ (lang.assert Cannot-Set-Final-Field (format class "#" field)
+ (not final?))
+ valueA (typeA.with-type fieldT
+ (analyse valueC))]
+ (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA objectA))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))
+
+ _
+ (lang.throw /.incorrect-special-arity [proc +4 (list.size args)]))))
+
+(def: (java-type-to-parameter type)
+ (-> java/lang/reflect/Type (Meta Text))
+ (cond (host.instance? Class type)
+ (macro/wrap (Class::getName [] (:! Class type)))
+
+ (host.instance? ParameterizedType type)
+ (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type)))
+
+ (or (host.instance? TypeVariable type)
+ (host.instance? WildcardType type))
+ (macro/wrap "java.lang.Object")
+
+ (host.instance? GenericArrayType type)
+ (do macro.Monad<Meta>
+ [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))]
+ (wrap (format componentP "[]")))
+
+ ## else
+ (lang.throw Cannot-Convert-To-Parameter (jvm-type-name type))))
+
+(type: Method-Type
+ #Static
+ #Abstract
+ #Virtual
+ #Special
+ #Interface)
+
+(def: (check-method class method-name method-type arg-classes method)
+ (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool))
+ (do macro.Monad<Meta>
+ [parameters (|> (Method::getGenericParameterTypes [] method)
+ array.to-list
+ (monad.map @ java-type-to-parameter))
+ #let [modifiers (Method::getModifiers [] method)]]
+ (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method))
+ (text/= method-name (Method::getName [] method))
+ (case #Static
+ #Special
+ (Modifier::isStatic [modifiers])
+
+ _
+ true)
+ (case method-type
+ #Special
+ (not (or (Modifier::isInterface [(Class::getModifiers [] class)])
+ (Modifier::isAbstract [modifiers])))
+
+ _
+ true)
+ (n/= (list.size arg-classes) (list.size parameters))
+ (list/fold (function (_ [expectedJC actualJC] prev)
+ (and prev
+ (text/= expectedJC actualJC)))
+ true
+ (list.zip2 arg-classes parameters))))))
+
+(def: (check-constructor class arg-classes constructor)
+ (-> (Class Object) (List Text) (Constructor Object) (Meta Bool))
+ (do macro.Monad<Meta>
+ [parameters (|> (Constructor::getGenericParameterTypes [] constructor)
+ array.to-list
+ (monad.map @ java-type-to-parameter))]
+ (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor))
+ (n/= (list.size arg-classes) (list.size parameters))
+ (list/fold (function (_ [expectedJC actualJC] prev)
+ (and prev
+ (text/= expectedJC actualJC)))
+ true
+ (list.zip2 arg-classes parameters))))))
+
+(def: idx-to-bound
+ (-> Nat Type)
+ (|>> (n/* +2) inc #.Bound))
+
+(def: (type-vars amount offset)
+ (-> Nat Nat (List Type))
+ (if (n/= +0 amount)
+ (list)
+ (|> (list.n/range offset (|> amount dec (n/+ offset)))
+ (list/map idx-to-bound))))
+
+(def: (method-to-type method-type method)
+ (-> Method-Type Method (Meta [Type (List Type)]))
+ (let [owner (Method::getDeclaringClass [] method)
+ owner-name (Class::getName [] owner)
+ owner-tvars (case method-type
+ #Static
+ (list)
+
+ _
+ (|> (Class::getTypeParameters [] owner)
+ array.to-list
+ (list/map (TypeVariable::getName []))))
+ method-tvars (|> (Method::getTypeParameters [] method)
+ array.to-list
+ (list/map (TypeVariable::getName [])))
+ num-owner-tvars (list.size owner-tvars)
+ num-method-tvars (list.size method-tvars)
+ all-tvars (list/compose owner-tvars method-tvars)
+ num-all-tvars (list.size all-tvars)
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ method-tvarsT (type-vars num-method-tvars num-owner-tvars)
+ mappings (: Mappings
+ (if (list.empty? all-tvars)
+ fresh-mappings
+ (|> (list/compose owner-tvarsT method-tvarsT)
+ list.reverse
+ (list.zip2 all-tvars)
+ (dict.from-list text.Hash<Text>))))]
+ (do macro.Monad<Meta>
+ [inputsT (|> (Method::getGenericParameterTypes [] method)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method))
+ exceptionsT (|> (Method::getGenericExceptionTypes [] method)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ #let [methodT (<| (type.univ-q num-all-tvars)
+ (type.function (case method-type
+ #Static
+ inputsT
+
+ _
+ (list& (#.Primitive owner-name (list.reverse owner-tvarsT))
+ inputsT)))
+ outputT)]]
+ (wrap [methodT exceptionsT]))))
+
+(def: (methods class-name method-name method-type arg-classes)
+ (-> Text Text Method-Type (List Text) (Meta [Type (List Type)]))
+ (do macro.Monad<Meta>
+ [class (load-class class-name)
+ candidates (|> class
+ (Class::getDeclaredMethods [])
+ array.to-list
+ (monad.map @ (function (_ method)
+ (do @
+ [passes? (check-method class method-name method-type arg-classes method)]
+ (wrap [passes? method])))))]
+ (case (list.filter product.left candidates)
+ #.Nil
+ (lang.throw No-Candidates (format class-name "#" method-name))
+
+ (#.Cons candidate #.Nil)
+ (|> candidate product.right (method-to-type method-type))
+
+ _
+ (lang.throw Too-Many-Candidates (format class-name "#" method-name)))))
+
+(def: (constructor-to-type constructor)
+ (-> (Constructor Object) (Meta [Type (List Type)]))
+ (let [owner (Constructor::getDeclaringClass [] constructor)
+ owner-name (Class::getName [] owner)
+ owner-tvars (|> (Class::getTypeParameters [] owner)
+ array.to-list
+ (list/map (TypeVariable::getName [])))
+ constructor-tvars (|> (Constructor::getTypeParameters [] constructor)
+ array.to-list
+ (list/map (TypeVariable::getName [])))
+ num-owner-tvars (list.size owner-tvars)
+ all-tvars (list/compose owner-tvars constructor-tvars)
+ num-all-tvars (list.size all-tvars)
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ constructor-tvarsT (type-vars num-all-tvars num-owner-tvars)
+ mappings (: Mappings
+ (if (list.empty? all-tvars)
+ fresh-mappings
+ (|> (list/compose owner-tvarsT constructor-tvarsT)
+ list.reverse
+ (list.zip2 all-tvars)
+ (dict.from-list text.Hash<Text>))))]
+ (do macro.Monad<Meta>
+ [inputsT (|> (Constructor::getGenericParameterTypes [] constructor)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT))
+ constructorT (<| (type.univ-q num-all-tvars)
+ (type.function inputsT)
+ objectT)]]
+ (wrap [constructorT exceptionsT]))))
+
+(def: (constructor-methods class-name arg-classes)
+ (-> Text (List Text) (Meta [Type (List Type)]))
+ (do macro.Monad<Meta>
+ [class (load-class class-name)
+ candidates (|> class
+ (Class::getConstructors [])
+ array.to-list
+ (monad.map @ (function (_ constructor)
+ (do @
+ [passes? (check-constructor class arg-classes constructor)]
+ (wrap [passes? constructor])))))]
+ (case (list.filter product.left candidates)
+ #.Nil
+ (lang.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")"))
+
+ (#.Cons candidate #.Nil)
+ (|> candidate product.right constructor-to-type)
+
+ _
+ (lang.throw Too-Many-Candidates class-name))))
+
+(def: (decorate-inputs typesT inputsA)
+ (-> (List Text) (List Analysis) (List Analysis))
+ (|> inputsA
+ (list.zip2 (list/map analysisL.text typesT))
+ (list/map (function (_ [type value])
+ (analysisL.product-analysis (list type value))))))
+
+(def: (invoke//static proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case (: (e.Error [Text Text (List [Text Code])])
+ (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class method argsTC])
+ (do macro.Monad<Meta>
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (methods class method #Static argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))
+ outputJC (check-jvm outputT)]
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method)
+ (analysisL.text outputJC) (decorate-inputs argsT argsA)))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))))
+
+(def: (invoke//virtual proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case (: (e.Error [Text Text Code (List [Text Code])])
+ (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class method objectC argsTC])
+ (do macro.Monad<Meta>
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (methods class method #Virtual argsT)
+ [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
+ #let [[objectA argsA] (case allA
+ (#.Cons objectA argsA)
+ [objectA argsA]
+
+ _
+ (undefined))]
+ outputJC (check-jvm outputT)]
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method)
+ (analysisL.text outputJC) objectA (decorate-inputs argsT argsA)))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))))
+
+(def: (invoke//special proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]])
+ (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!)))
+ (#e.Success [_ [class method objectC argsTC _]])
+ (do macro.Monad<Meta>
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (methods class method #Special argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
+ outputJC (check-jvm outputT)]
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method)
+ (analysisL.text outputJC) (decorate-inputs argsT argsA)))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))))
+
+(def: (invoke//interface proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case (: (e.Error [Text Text Code (List [Text Code])])
+ (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class-name method objectC argsTC])
+ (do macro.Monad<Meta>
+ [#let [argsT (list/map product.left argsTC)]
+ class (load-class class-name)
+ _ (lang.assert non-interface class-name
+ (Modifier::isInterface [(Class::getModifiers [] class)]))
+ [methodT exceptionsT] (methods class-name method #Interface argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
+ outputJC (check-jvm outputT)]
+ (wrap (#analysisL.Special proc
+ (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC)
+ (decorate-inputs argsT argsA)))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))))
+
+(def: (invoke//constructor proc)
+ (-> Text ///.Analysis)
+ (function (_ analyse eval args)
+ (case (: (e.Error [Text (List [Text Code])])
+ (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class argsTC])
+ (do macro.Monad<Meta>
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (constructor-methods class argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))]
+ (wrap (#analysisL.Special proc (list& (analysisL.text class) (decorate-inputs argsT argsA)))))
+
+ _
+ (lang.throw /.invalid-syntax [proc args]))))
+
+(def: member-procs
+ /.Bundle
+ (<| (/.prefix "member")
+ (|> (dict.new text.Hash<Text>)
+ (dict.merge (<| (/.prefix "static")
+ (|> (dict.new text.Hash<Text>)
+ (/.install "get" static//get)
+ (/.install "put" static//put))))
+ (dict.merge (<| (/.prefix "virtual")
+ (|> (dict.new text.Hash<Text>)
+ (/.install "get" virtual//get)
+ (/.install "put" virtual//put))))
+ (dict.merge (<| (/.prefix "invoke")
+ (|> (dict.new text.Hash<Text>)
+ (/.install "static" invoke//static)
+ (/.install "virtual" invoke//virtual)
+ (/.install "special" invoke//special)
+ (/.install "interface" invoke//interface)
+ (/.install "constructor" invoke//constructor)
+ )))
+ )))
+
+(def: #export specials
+ /.Bundle
+ (<| (/.prefix "jvm")
+ (|> (dict.new text.Hash<Text>)
+ (dict.merge conversion-procs)
+ (dict.merge int-procs)
+ (dict.merge long-procs)
+ (dict.merge float-procs)
+ (dict.merge double-procs)
+ (dict.merge char-procs)
+ (dict.merge array-procs)
+ (dict.merge object-procs)
+ (dict.merge member-procs)
+ )))
diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux
index 80e6d4740..8d4fdf981 100644
--- a/stdlib/source/lux/lang/init.lux
+++ b/stdlib/source/lux/lang/init.lux
@@ -1,11 +1,11 @@
(.module:
lux
- ## (// [".L" extension]
- ## (extension [".E" analysis]
- ## [".E" synthesis]
- ## [".E" translation]
- ## [".E" statement]))
- )
+ (// [".L" extension]
+ (extension [".E" analysis]
+ ## [".E" synthesis]
+ ## [".E" translation]
+ ## [".E" statement]
+ )))
(def: #export (cursor file)
(-> Text Cursor)
@@ -30,7 +30,13 @@
(def: #export info
Info
{#.target (for {"JVM" "JVM"
- "JS" "JS"})
+ "JS" "JS"
+ "Lua" "Lua"
+ "Python" "Python"
+ "Ruby" "Ruby"
+ "PHP" "PHP"
+ "Scheme" "Scheme"
+ "Common Lisp" "Common Lisp"})
#.version ..version
#.mode #.Build})
@@ -47,10 +53,9 @@
#.seed +0
#.scope-type-vars (list)
#.extensions (:! Nothing
- []
- ## {#extensionL.analysis analysisE.defaults
- ## #extensionL.synthesis synthesisE.defaults
- ## #extensionL.translation translationE.defaults
- ## #extensionL.statement statementE.defaults}
- )
+ {#extensionL.analysis analysisE.defaults
+ #extensionL.synthesis (:!! []) ## synthesisE.defaults
+ #extensionL.translation (:!! []) ## translationE.defaults
+ #extensionL.statement (:!! []) ## statementE.defaults
+ })
#.host (:! Nothing host)})
diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux
new file mode 100644
index 000000000..33c8aa063
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis.lux
@@ -0,0 +1,8 @@
+(.module:
+ lux)
+
+(def: #export Arity Nat)
+
+(type: #export Synthesis Code)
+
+(type: #export Path Code)
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 23:08:44 +0000