From 8a51602b3507a18a5ffae1710ba4e915cf31fe39 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 5 Dec 2017 16:40:15 -0400
Subject: - All analysis procedures have been turned into extensions.
---
new-luxc/source/luxc/lang/analysis/expression.lux | 8 +-
new-luxc/source/luxc/lang/analysis/procedure.lux | 26 -
.../source/luxc/lang/analysis/procedure/common.lux | 421 -------
.../luxc/lang/analysis/procedure/host.jvm.lux | 1242 -------------------
new-luxc/source/luxc/lang/extension.lux | 32 +-
new-luxc/source/luxc/lang/extension/analysis.lux | 18 +-
.../source/luxc/lang/extension/analysis/common.lux | 419 +++++++
.../luxc/lang/extension/analysis/host.jvm.lux | 1243 ++++++++++++++++++++
new-luxc/source/luxc/lang/extension/statement.lux | 8 +-
new-luxc/source/luxc/lang/extension/synthesis.lux | 2 +-
.../source/luxc/lang/extension/translation.lux | 2 +-
.../luxc/lang/translation/procedure/host.jvm.lux | 2 +-
12 files changed, 1708 insertions(+), 1715 deletions(-)
delete mode 100644 new-luxc/source/luxc/lang/analysis/procedure.lux
delete mode 100644 new-luxc/source/luxc/lang/analysis/procedure/common.lux
delete mode 100644 new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/extension/analysis/common.lux
create mode 100644 new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
index 1463e7ec5..d19e98bd8 100644
--- a/new-luxc/source/luxc/lang/analysis/expression.lux
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -13,14 +13,14 @@
(lang ["&." module]
[".L" host]
[".L" macro]
+ [".L" extension]
["la" analysis]
(translation [".T" common])))
(// [".A" common]
[".A" function]
[".A" primitive]
[".A" reference]
- [".A" structure]
- [".A" procedure]))
+ [".A" structure]))
(exception: #export Macro-Expression-Must-Have-Single-Expansion)
(exception: #export Unrecognized-Syntax)
@@ -64,7 +64,9 @@
(referenceA.analyse-reference reference)
(^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
- (procedureA.analyse-procedure analyse eval proc-name proc-args)
+ (do macro.Monad
+ [procedure (extensionL.find-analysis proc-name)]
+ (procedure analyse eval proc-args))
(^template [ ]
(^ (#.Form (list& [_ ( tag)]
diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux
deleted file mode 100644
index 25e1be335..000000000
--- a/new-luxc/source/luxc/lang/analysis/procedure.lux
+++ /dev/null
@@ -1,26 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data [maybe]
- [text]
- text/format
- (coll [dict])))
- (luxc ["&" lang]
- (lang ["la" analysis]))
- (/ ["/." common]
- ["/." host]))
-
-(exception: #export Unknown-Procedure)
-
-(def: procedures
- /common.Bundle
- (|> /common.procedures
- (dict.merge /host.procedures)))
-
-(def: #export (analyse-procedure analyse eval proc-name proc-args)
- (-> &.Analyser &.Eval Text (List Code) (Meta la.Analysis))
- (<| (maybe.default (&.throw Unknown-Procedure (%t proc-name)))
- (do maybe.Monad
- [proc (dict.get proc-name procedures)]
- (wrap ((proc proc-name) analyse eval proc-args)))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
deleted file mode 100644
index ecdcd0bfd..000000000
--- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux
+++ /dev/null
@@ -1,421 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (concurrency [atom #+ Atom])
- (data [text]
- text/format
- (coll [list "list/" Functor]
- [array]
- [dict #+ Dict]))
- [macro]
- (macro [code])
- (lang (type ["tc" check]))
- [io])
- (luxc ["&" lang]
- (lang ["la" analysis]
- (analysis ["&." common]
- [".A" function]
- [".A" case]
- [".A" type]))))
-
-(exception: #export Incorrect-Procedure-Arity)
-(exception: #export Invalid-Syntax)
-
-## [Utils]
-(type: #export Proc
- (-> &.Analyser &.Eval (List Code) (Meta la.Analysis)))
-
-(type: #export Bundle
- (Dict Text (-> Text Proc)))
-
-(def: #export (install name unnamed)
- (-> Text (-> Text Proc)
- (-> 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)))
-
-(def: #export (wrong-arity proc expected actual)
- (-> Text Nat Nat Text)
- (format " Procedure: " (%t proc) "\n"
- " Expected Arity: " (|> expected nat-to-int %i) "\n"
- " Actual Arity: " (|> actual nat-to-int %i)))
-
-(def: (simple proc inputsT+ outputT)
- (-> Text (List Type) Type Proc)
- (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
- [_ (&.infer outputT)
- argsA (monad.map @
- (function [[argT argC]]
- (&.with-type argT
- (analyse argC)))
- (list.zip2 inputsT+ args))]
- (wrap (la.procedure proc argsA)))
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual)))))))
-
-(def: #export (nullary valueT proc)
- (-> Type Text Proc)
- (simple proc (list) valueT))
-
-(def: #export (unary inputT outputT proc)
- (-> Type Type Text Proc)
- (simple proc (list inputT) outputT))
-
-(def: #export (binary subjectT paramT outputT proc)
- (-> Type Type Type Text Proc)
- (simple proc (list subjectT paramT) outputT))
-
-(def: #export (trinary subjectT param0T param1T outputT proc)
- (-> Type Type Type Type Text Proc)
- (simple proc (list subjectT param0T param1T) outputT))
-
-## [Analysers]
-## "lux is" represents reference/pointer equality.
-(def: (lux//is proc)
- (-> Text Proc)
- (function [analyse eval args]
- (do macro.Monad
- [[var-id varT] (&.with-type-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 Proc)
- (function [analyse eval args]
- (case args
- (^ (list opC))
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (Either Text varT)))
- opA (&.with-type (type (io.IO varT))
- (analyse opC))]
- (wrap (la.procedure proc (list opA))))
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
-
-(def: (lux//function proc)
- (-> Text Proc)
- (function [analyse eval args]
- (case args
- (^ (list [_ (#.Symbol ["" func-name])]
- [_ (#.Symbol ["" arg-name])]
- body))
- (functionA.analyse-function analyse func-name arg-name body)
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args))))))
-
-(def: (lux//case proc)
- (-> Text Proc)
- (function [analyse eval args]
- (case args
- (^ (list input [_ (#.Record branches)]))
- (caseA.analyse-case analyse input branches)
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))
-
-(def: (lux//in-module proc)
- (-> Text Proc)
- (function [analyse eval argsC+]
- (case argsC+
- (^ (list [_ (#.Text module-name)] exprC))
- (&.with-current-module module-name
- (analyse exprC))
-
- _
- (&.throw Invalid-Syntax (format "Procedure: " proc "\n"
- " Inputs:" (|> argsC+
- list.enumerate
- (list/map (function [[idx argC]]
- (format "\n " (%n idx) " " (%code argC))))
- (text.join-with "")) "\n")))))
-
-(do-template [ ]
- [(def: ( proc)
- (-> Text Proc)
- (function [analyse eval args]
- (case args
- (^ (list typeC valueC))
- ( analyse eval typeC valueC)
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))]
-
- [lux//check typeA.analyse-check]
- [lux//coerce typeA.analyse-coerce])
-
-(def: (lux//check//type proc)
- (-> Text Proc)
- (function [analyse eval args]
- (case args
- (^ (list valueC))
- (do macro.Monad
- [_ (&.infer (type Type))
- valueA (&.with-type Type
- (analyse valueC))]
- (wrap valueA))
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
-
-(def: lux-procs
- Bundle
- (|> (dict.new text.Hash)
- (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)
- (install "log" (unary Text Unit))
- (install "error" (unary Text Bottom))
- (install "exit" (unary Int Bottom))
- (install "current-time" (nullary Int)))))
-
-(def: bit-procs
- Bundle
- (<| (prefix "bit")
- (|> (dict.new text.Hash)
- (install "count" (unary Nat Nat))
- (install "and" (binary Nat Nat Nat))
- (install "or" (binary Nat Nat Nat))
- (install "xor" (binary Nat Nat Nat))
- (install "shift-left" (binary Nat Nat Nat))
- (install "unsigned-shift-right" (binary Nat Nat Nat))
- (install "shift-right" (binary Int Nat Int))
- )))
-
-(def: nat-procs
- Bundle
- (<| (prefix "nat")
- (|> (dict.new text.Hash)
- (install "+" (binary Nat Nat Nat))
- (install "-" (binary Nat Nat Nat))
- (install "*" (binary Nat Nat Nat))
- (install "/" (binary Nat Nat Nat))
- (install "%" (binary Nat Nat Nat))
- (install "=" (binary Nat Nat Bool))
- (install "<" (binary Nat Nat Bool))
- (install "min" (nullary Nat))
- (install "max" (nullary Nat))
- (install "to-int" (unary Nat Int))
- (install "char" (unary Nat Text)))))
-
-(def: int-procs
- Bundle
- (<| (prefix "int")
- (|> (dict.new text.Hash)
- (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)))))
-
-(def: deg-procs
- Bundle
- (<| (prefix "deg")
- (|> (dict.new text.Hash)
- (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)
- (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)
- (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))))
- (install "upper" (unary Text Text))
- (install "lower" (unary Text Text))
- )))
-
-(def: (array//get proc)
- (-> Text Proc)
- (function [analyse eval args]
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)]
- ((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
- analyse eval args))))
-
-(def: (array//put proc)
- (-> Text Proc)
- (function [analyse eval args]
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)]
- ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
- analyse eval args))))
-
-(def: (array//remove proc)
- (-> Text Proc)
- (function [analyse eval args]
- (do macro.Monad
- [[var-id varT] (&.with-type-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)
- (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)
- (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 "root2" (unary Frac Frac))
- (install "root3" (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 Proc)
- (function [analyse eval args]
- (case args
- (^ (list initC))
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (Atom varT)))
- initA (&.with-type varT
- (analyse initC))]
- (wrap (la.procedure proc (list initA))))
-
- _
- (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
-
-(def: (atom-read proc)
- (-> Text Proc)
- (function [analyse eval args]
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)]
- ((unary (type (Atom varT)) varT proc)
- analyse eval args))))
-
-(def: (atom//compare-and-swap proc)
- (-> Text Proc)
- (function [analyse eval args]
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)]
- ((trinary (type (Atom varT)) varT varT Bool proc)
- analyse eval args))))
-
-(def: atom-procs
- Bundle
- (<| (prefix "atom")
- (|> (dict.new text.Hash)
- (install "new" atom-new)
- (install "read" atom-read)
- (install "compare-and-swap" atom//compare-and-swap)
- )))
-
-(def: process-procs
- Bundle
- (<| (prefix "process")
- (|> (dict.new text.Hash)
- (install "concurrency-level" (nullary Nat))
- (install "future" (unary (type (io.IO Top)) Unit))
- (install "schedule" (binary Nat (type (io.IO Top)) Unit))
- )))
-
-(def: #export procedures
- Bundle
- (<| (prefix "lux")
- (|> (dict.new text.Hash)
- (dict.merge lux-procs)
- (dict.merge bit-procs)
- (dict.merge nat-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 process-procs)
- (dict.merge io-procs))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
deleted file mode 100644
index 3c29410d0..000000000
--- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
+++ /dev/null
@@ -1,1242 +0,0 @@
-(.module:
- [lux #- char]
- (lux (control [monad #+ do]
- ["p" parser]
- ["ex" exception #+ exception:])
- (concurrency ["A" atom])
- (data ["e" error]
- [maybe]
- [product]
- [bool "bool/" Eq]
- [text "text/" Eq]
- (text format
- ["l" lexer])
- (coll [list "list/" Fold Functor Monoid]
- [array]
- [dict #+ Dict]))
- [macro "macro/" Monad]
- (macro [code]
- ["s" syntax])
- (lang [type]
- (type ["tc" check]))
- [host])
- (luxc ["&" lang]
- (lang ["&." host]
- ["la" analysis]
- (analysis ["&." common]
- [".A" inference])))
- ["@" //common]
- )
-
-(exception: #export Wrong-Syntax)
-(def: (wrong-syntax procedure args)
- (-> Text (List Code) Text)
- (format "Procedure: " procedure "\n"
- "Arguments: " (%code (code.tuple args))))
-
-(exception: #export JVM-Type-Is-Not-Class)
-
-(exception: #export Non-Interface)
-(exception: #export Non-Object)
-(exception: #export Non-Array)
-(exception: #export Non-Throwable)
-(exception: #export Non-JVM-Type)
-
-(exception: #export Unknown-Class)
-(exception: #export Primitives-Cannot-Have-Type-Parameters)
-(exception: #export Primitives-Are-Not-Objects)
-(exception: #export Invalid-Type-For-Array-Element)
-
-(exception: #export Unknown-Field)
-(exception: #export Mistaken-Field-Owner)
-(exception: #export Not-Virtual-Field)
-(exception: #export Not-Static-Field)
-(exception: #export Cannot-Set-Final-Field)
-
-(exception: #export No-Candidates)
-(exception: #export Too-Many-Candidates)
-
-(exception: #export Cannot-Cast)
-(def: (cannot-cast to from)
- (-> Type Type Text)
- (format "From: " (%type from) "\n"
- " To: " (%type to)))
-
-(exception: #export Cannot-Possibly-Be-Instance)
-
-(exception: #export Cannot-Convert-To-Class)
-(exception: #export Cannot-Convert-To-Parameter)
-(exception: #export Cannot-Convert-To-Lux-Type)
-(exception: #export Unknown-Type-Var)
-(exception: #export Type-Parameter-Mismatch)
-(exception: #export Cannot-Correspond-Type-With-Class)
-
-(def: #export null-class Text "#Null")
-
-(do-template [ ]
- [(def: #export Type (#.Primitive (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)
- (@.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 [ ]
- [(def:
- @.Bundle
- (<| (@.prefix )
- (|> (dict.new text.Hash)
- (@.install "+" (@.binary ))
- (@.install "-" (@.binary ))
- (@.install "*" (@.binary ))
- (@.install "/" (@.binary ))
- (@.install "%" (@.binary ))
- (@.install "=" (@.binary Boolean))
- (@.install "<" (@.binary Boolean))
- (@.install "and" (@.binary ))
- (@.install "or" (@.binary ))
- (@.install "xor" (@.binary ))
- (@.install "shl" (@.binary Integer ))
- (@.install "shr" (@.binary Integer ))
- (@.install "ushr" (@.binary Integer ))
- )))]
-
- [int-procs "int" Integer]
- [long-procs "long" Long]
- )
-
-(do-template [ ]
- [(def:
- @.Bundle
- (<| (@.prefix )
- (|> (dict.new text.Hash)
- (@.install "+" (@.binary ))
- (@.install "-" (@.binary ))
- (@.install "*" (@.binary ))
- (@.install "/" (@.binary ))
- (@.install "%" (@.binary ))
- (@.install "=" (@.binary Boolean))
- (@.install "<" (@.binary Boolean))
- )))]
-
- [float-procs "float" Float]
- [double-procs "double" Double]
- )
-
-(def: char-procs
- @.Bundle
- (<| (@.prefix "char")
- (|> (dict.new text.Hash)
- (@.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)))
-
-(def: (array-length proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list arrayC))
- (do macro.Monad
- [_ (&.infer Nat)
- [var-id varT] (&.with-type-env tc.var)
- arrayA (&.with-type (type (Array varT))
- (analyse arrayC))]
- (wrap (la.procedure proc (list arrayA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (array-new proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list lengthC))
- (do macro.Monad
- [lengthA (&.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
- (&.throw Non-Array (%type expectedT)))
-
- (^ (#.Primitive "#Array" (list elemT)))
- (recur elemT (n/inc level))
-
- (#.Primitive class _)
- (wrap [level class])
-
- _
- (&.throw Non-Array (%type expectedT)))))
- _ (if (n/> +0 level)
- (wrap [])
- (&.throw Non-Array (%type expectedT)))]
- (wrap (la.procedure proc (list (code.nat (n/dec level)) (code.text elem-class) lengthA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-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 []
- ( env unquantified)
- (check-jvm unquantified))
- ([#.UnivQ]
- [#.ExQ])
-
- (#.Apply inputT funcT)
- (case (type.apply (list inputT) funcT)
- (#.Some outputT)
- (check-jvm outputT)
-
- #.None
- (&.throw Non-Object (%type objectT)))
-
- _
- (&.throw Non-Object (%type objectT))))
-
-(def: (check-object objectT)
- (-> Type (Meta Text))
- (do macro.Monad
- [name (check-jvm objectT)]
- (if (dict.contains? name boxes)
- (&.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)
- (&.throw Primitives-Cannot-Have-Type-Parameters name)
- (macro/wrap [elemT name]))
-
- _
- (&.throw Invalid-Type-For-Array-Element (%type elemT))))
-
-(def: (array-read proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list arrayC idxC))
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer varT)
- arrayA (&.with-type (type (Array varT))
- (analyse arrayC))
- ?elemT (&.with-type-env
- (tc.read var-id))
- [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
- idxA (&.with-type Nat
- (analyse idxC))]
- (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(def: (array-write proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list arrayC idxC valueC))
- (do macro.Monad
- [[var-id varT] (&.with-type-env tc.var)
- _ (&.infer (type (Array varT)))
- arrayA (&.with-type (type (Array varT))
- (analyse arrayC))
- ?elemT (&.with-type-env
- (tc.read var-id))
- [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
- idxA (&.with-type Nat
- (analyse idxC))
- valueA (&.with-type valueT
- (analyse valueC))]
- (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-
-(def: array-procs
- @.Bundle
- (<| (@.prefix "array")
- (|> (dict.new text.Hash)
- (@.install "length" array-length)
- (@.install "new" array-new)
- (@.install "read" array-read)
- (@.install "write" array-write)
- )))
-
-(def: (object-null proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list))
- (do macro.Monad
- [expectedT macro.expected-type
- _ (check-object expectedT)]
- (wrap (la.procedure proc (list))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args))))))
-
-(def: (object-null? proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list objectC))
- (do macro.Monad
- [_ (&.infer Bool)
- [objectT objectA] (&common.with-unknown-type
- (analyse objectC))
- _ (check-object objectT)]
- (wrap (la.procedure proc (list objectA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (object-synchronized proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list monitorC exprC))
- (do macro.Monad
- [[monitorT monitorA] (&common.with-unknown-type
- (analyse monitorC))
- _ (check-object monitorT)
- exprA (analyse exprC)]
- (wrap (la.procedure proc (list monitorA exprA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(host.import java/lang/Object
- (equals [Object] boolean))
-
-(host.import java/lang/ClassLoader)
-
-(host.import #long java/lang/reflect/Type
- (getTypeName [] String))
-
-(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 boolean ClassLoader] #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
- [class-loader &host.class-loader]
- (case (Class::forName [name false class-loader])
- (#e.Success [class])
- (wrap class)
-
- (#e.Error error)
- (&.throw Unknown-Class name))))
-
-(def: (sub-class? super sub)
- (-> Text Text (Meta Bool))
- (do macro.Monad
- [super (load-class super)
- sub (load-class sub)]
- (wrap (Class::isAssignableFrom [sub] super))))
-
-(def: (object-throw proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list exceptionC))
- (do macro.Monad
- [_ (&.infer Bottom)
- [exceptionT exceptionA] (&common.with-unknown-type
- (analyse exceptionC))
- exception-class (check-object exceptionT)
- ? (sub-class? "java.lang.Throwable" exception-class)
- _ (: (Meta Unit)
- (if ?
- (wrap [])
- (&.throw Non-Throwable exception-class)))]
- (wrap (la.procedure proc (list exceptionA))))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (object-class proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list classC))
- (case classC
- [_ (#.Text class)]
- (do macro.Monad
- [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
- _ (load-class class)]
- (wrap (la.procedure proc (list (code.text class)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-
-(def: (object-instance? proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list classC objectC))
- (case classC
- [_ (#.Text class)]
- (do macro.Monad
- [_ (&.infer Bool)
- [objectT objectA] (&common.with-unknown-type
- (analyse objectC))
- object-class (check-object objectT)
- ? (sub-class? class object-class)]
- (if ?
- (wrap (la.procedure proc (list (code.text class))))
- (&.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(def: object-procs
- @.Bundle
- (<| (@.prefix "object")
- (|> (dict.new text.Hash)
- (@.install "null" object-null)
- (@.install "null?" object-null?)
- (@.install "synchronized" object-synchronized)
- (@.install "throw" object-throw)
- (@.install "class" object-class)
- (@.install "instance?" object-instance?)
- )))
-
-(def: type-descriptor
- (-> java/lang/reflect/Type Text)
- (java/lang/reflect/Type::getTypeName []))
-
-(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
- (&.throw Cannot-Convert-To-Class (type-descriptor type))))
-
-(type: Mappings
- (Dict Text Type))
-
-(def: fresh-mappings Mappings (dict.new text.Hash))
-
-(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
- (&.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 Top)))
-
- (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 (n/dec arity))
- list.reverse
- (list/map (|>> (n/* +2) n/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
- [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)))
- (&.throw JVM-Type-Is-Not-Class (type-descriptor raw))))
-
- (host.instance? GenericArrayType java-type)
- (do macro.Monad
- [innerT (|> (:! GenericArrayType java-type)
- (GenericArrayType::getGenericComponentType [])
- (java-type-to-lux-type mappings))]
- (wrap (#.Primitive "#Array" (list innerT))))
-
- ## else
- (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
-
-(type: Direction
- #In
- #Out)
-
-(def: (choose direction to from)
- (-> Direction Text Text Text)
- (case direction
- #In to
- #Out from))
-
-(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))
- (&.throw Cannot-Correspond-Type-With-Class
- (format "Class = " class-name "\n"
- "Type = " (%type type)))
-
- (not (n/= num-class-params num-type-params))
- (&.throw Type-Parameter-Mismatch
- (format "Expected: " (%i (nat-to-int num-class-params)) "\n"
- " Actual: " (%i (nat-to-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)))
- ))
-
- _
- (&.throw Non-JVM-Type (%type type))))
-
-(def: (cast direction to from)
- (-> Direction Type Type (Meta [Text Type]))
- (do macro.Monad
- [to-name (check-jvm to)
- from-name (check-jvm from)]
- (cond (dict.contains? to-name boxes)
- (let [box (maybe.assume (dict.get to-name boxes))]
- (if (text/= box from-name)
- (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))])
- (&.throw Cannot-Cast (cannot-cast to from))))
-
- (dict.contains? from-name boxes)
- (let [box (maybe.assume (dict.get from-name boxes))]
- (do @
- [[_ castT] (cast direction to (#.Primitive box (list)))]
- (wrap [(choose direction to-name from-name) castT])))
-
- (text/= to-name from-name)
- (wrap [(choose direction to-name from-name) from])
-
- (text/= null-class from-name)
- (wrap [(choose direction to-name from-name) to])
-
- ## else
- (do @
- [to-class (load-class to-name)
- from-class (load-class from-name)
- _ (&.assert Cannot-Cast (cannot-cast to from)
- (Class::isAssignableFrom [from-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 [java-type (Class::isAssignableFrom [class] to-class)])))
- (list& (Class::getGenericSuperclass [] from-class)
- (array.to-list (Class::getGenericInterfaces [] from-class))))]
- (case (|> candiate-parents
- (list.filter product.right)
- (list/map product.left))
- (#.Cons parent _)
- (do @
- [mapping (correspond-type-params from-class from)
- parentT (java-type-to-lux-type mapping parent)
- [_ castT] (cast direction to parentT)]
- (wrap [(choose direction to-name from-name) castT]))
-
- #.Nil
- (&.throw Cannot-Cast (cannot-cast to from)))))))
-
-(def: (infer-out outputT)
- (-> Type (Meta [Text Type]))
- (do macro.Monad
- [expectedT macro.expected-type
- [unboxed castT] (cast #Out expectedT outputT)
- _ (&.with-type-env
- (tc.check expectedT castT))]
- (wrap [unboxed castT])))
-
-(def: (find-field class-name field-name)
- (-> Text Text (Meta [(Class Object) Field]))
- (do macro.Monad
- [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])
- (&.throw Mistaken-Field-Owner
- (format " Field: " field-name "\n"
- " Owner Class: " (Class::getName [] owner) "\n"
- "Target Class: " class-name "\n"))))
-
- (#e.Error _)
- (&.throw Unknown-Field (format class-name "#" field-name)))))
-
-(def: (static-field class-name field-name)
- (-> Text Text (Meta [Type Bool]))
- (do macro.Monad
- [[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])])))
- (&.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
- [[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)]
- _ (&.assert Type-Parameter-Mismatch
- (format "Expected: " (%i (nat-to-int num-params)) "\n"
- " Actual: " (%i (nat-to-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))))
-
- _
- (&.throw Non-Object (%type objectT))))
- fieldT (java-type-to-lux-type mappings fieldJT)]
- (wrap [fieldT (Modifier::isFinal [modifiers])]))
- (&.throw Not-Virtual-Field (format class-name "#" field-name)))))
-
-(def: (analyse-object class analyse sourceC)
- (-> Text &.Analyser Code (Meta [Type la.Analysis]))
- (do macro.Monad
- [target-class (load-class class)
- targetT (java-type-to-lux-type fresh-mappings
- (:! java/lang/reflect/Type
- target-class))
- [sourceT sourceA] (&common.with-unknown-type
- (analyse sourceC))
- [unboxed castT] (cast #Out targetT sourceT)
- _ (&.assert Cannot-Cast (cannot-cast targetT sourceT)
- (not (dict.contains? unboxed boxes)))]
- (wrap [castT sourceA])))
-
-(def: (analyse-input analyse targetT sourceC)
- (-> &.Analyser Type Code (Meta [Type Text la.Analysis]))
- (do macro.Monad
- [[sourceT sourceA] (&common.with-unknown-type
- (analyse sourceC))
- [unboxed castT] (cast #In targetT sourceT)]
- (wrap [castT unboxed sourceA])))
-
-(def: (static-get proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list classC fieldC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad
- [[fieldT final?] (static-field class field)
- [unboxed castT] (infer-out fieldT)]
- (wrap (la.procedure proc (list (code.text class) (code.text field)
- (code.text unboxed)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-
-(def: (static-put proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list classC fieldC valueC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad
- [_ (&.infer Unit)
- [fieldT final?] (static-field class field)
- _ (&.assert Cannot-Set-Final-Field (format class "#" field)
- (not final?))
- [valueT unboxed valueA] (analyse-input analyse fieldT valueC)
- _ (&.with-type-env
- (tc.check fieldT valueT))]
- (wrap (la.procedure proc (list (code.text class) (code.text field)
- (code.text unboxed) valueA))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-
-(def: (virtual-get proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list classC fieldC objectC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad
- [[objectT objectA] (analyse-object class analyse objectC)
- [fieldT final?] (virtual-field class field objectT)
- [unboxed castT] (infer-out fieldT)]
- (wrap (la.procedure proc (list (code.text class) (code.text field)
- (code.text unboxed) objectA))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-
-(def: (virtual-put proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case args
- (^ (list classC fieldC valueC objectC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad
- [[objectT objectA] (analyse-object class analyse objectC)
- _ (&.infer objectT)
- [fieldT final?] (virtual-field class field objectT)
- _ (&.assert Cannot-Set-Final-Field (format class "#" field)
- (not final?))
- [valueT unboxed valueA] (analyse-input analyse fieldT valueC)]
- (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))
-
- _
- (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
- [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))]
- (wrap (format componentP "[]")))
-
- ## else
- (&.throw Cannot-Convert-To-Parameter (type-descriptor 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
- [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
- [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) n/inc #.Bound))
-
-(def: (type-vars amount offset)
- (-> Nat Nat (List Type))
- (if (n/= +0 amount)
- (list)
- (|> (list.n/range offset (|> amount n/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))))]
- (do macro.Monad
- [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
- [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
- (&.throw No-Candidates (format class-name "#" method-name))
-
- (#.Cons candidate #.Nil)
- (|> candidate product.right (method-to-type method-type))
-
- _
- (&.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))))]
- (do macro.Monad
- [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
- [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
- (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")"))
-
- (#.Cons candidate #.Nil)
- (|> candidate product.right constructor-to-type)
-
- _
- (&.throw Too-Many-Candidates class-name))))
-
-(def: (decorate-inputs typesT inputsA)
- (-> (List Text) (List la.Analysis) (List la.Analysis))
- (|> inputsA
- (list.zip2 (list/map code.text typesT))
- (list/map (function [[type value]]
- (la.product (list type value))))))
-
-(def: (sub-type-analyser analyse)
- (-> &.Analyser &.Analyser)
- (function [argC]
- (do macro.Monad
- [[argT argA] (&common.with-unknown-type
- (analyse argC))
- expectedT macro.expected-type
- [unboxed castT] (cast #In expectedT argT)]
- (wrap argA))))
-
-(def: (invoke//static proc)
- (-> Text @.Proc)
- (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
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (methods class method #Static argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC))
- [unboxed castT] (infer-out outputT)]
- (wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text unboxed) (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//virtual proc)
- (-> Text @.Proc)
- (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
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (methods class method #Virtual argsT)
- [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
- #let [[objectA argsA] (case allA
- (#.Cons objectA argsA)
- [objectA argsA]
-
- _
- (undefined))]
- [unboxed castT] (infer-out outputT)]
- (wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text unboxed) objectA (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//special proc)
- (-> Text @.Proc)
- (function [analyse eval args]
- (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Unit]])
- (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
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (methods class method #Special argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
- [unboxed castT] (infer-out outputT)]
- (wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text unboxed) (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//interface proc)
- (-> Text @.Proc)
- (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
- [#let [argsT (list/map product.left argsTC)]
- class (load-class class-name)
- _ (&.assert Non-Interface class-name
- (Modifier::isInterface [(Class::getModifiers [] class)]))
- [methodT exceptionsT] (methods class-name method #Interface argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
- [unboxed castT] (infer-out outputT)]
- (wrap (la.procedure proc
- (list& (code.text class-name) (code.text method) (code.text unboxed)
- (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: (invoke//constructor proc)
- (-> Text @.Proc)
- (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
- [#let [argsT (list/map product.left argsTC)]
- [methodT exceptionsT] (constructor-methods class argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC))
- [unboxed castT] (infer-out outputT)]
- (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA)))))
-
- _
- (&.throw Wrong-Syntax (wrong-syntax proc args)))))
-
-(def: member-procs
- @.Bundle
- (<| (@.prefix "member")
- (|> (dict.new text.Hash)
- (dict.merge (<| (@.prefix "static")
- (|> (dict.new text.Hash)
- (@.install "get" static-get)
- (@.install "put" static-put))))
- (dict.merge (<| (@.prefix "virtual")
- (|> (dict.new text.Hash)
- (@.install "get" virtual-get)
- (@.install "put" virtual-put))))
- (dict.merge (<| (@.prefix "invoke")
- (|> (dict.new text.Hash)
- (@.install "static" invoke//static)
- (@.install "virtual" invoke//virtual)
- (@.install "special" invoke//special)
- (@.install "interface" invoke//interface)
- (@.install "constructor" invoke//constructor)
- )))
- )))
-
-(def: #export procedures
- @.Bundle
- (<| (@.prefix "jvm")
- (|> (dict.new text.Hash)
- (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/new-luxc/source/luxc/lang/extension.lux b/new-luxc/source/luxc/lang/extension.lux
index d38d564fb..248bfbb71 100644
--- a/new-luxc/source/luxc/lang/extension.lux
+++ b/new-luxc/source/luxc/lang/extension.lux
@@ -18,16 +18,24 @@
(exception: #export Cannot-Define-Translation-More-Than-Once)
(exception: #export Cannot-Define-Statement-More-Than-Once)
-(type: #export Expression
+(type: #export Analysis
+ (-> (-> Code (Meta Code))
+ (-> Type Code (Meta Top))
+ (List Code) (Meta Code)))
+
+(type: #export Synthesis
+ (-> (List Code) (Meta Code)))
+
+(type: #export Translation
(-> (List Code) (Meta Code)))
(type: #export Statement
(-> (List Code) (Meta Unit)))
(type: #export Extensions
- {#analysis (Dict Text Expression)
- #synthesis (Dict Text Expression)
- #translation (Dict Text Expression)
+ {#analysis (Dict Text Analysis)
+ #synthesis (Dict Text Synthesis)
+ #translation (Dict Text Translation)
#statement (Dict Text Statement)})
(def: #export fresh
@@ -61,10 +69,10 @@
#.None
(//.throw name))))]
- [find-analysis Expression #analysis Unknown-Analysis]
- [find-synthesis Expression #synthesis Unknown-Synthesis]
- [find-translation Expression #translation Unknown-Translation]
- [find-statement Statement #statement Unknown-Statement]
+ [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 [ ]
@@ -77,8 +85,8 @@
_ (..set (update@ (dict.put name extension) extensions))]
(wrap [])))]
- [install-analysis Expression #analysis Cannot-Define-Analysis-More-Than-Once]
- [install-synthesis Expression #synthesis Cannot-Define-Synthesis-More-Than-Once]
- [install-translation Expression #translation Cannot-Define-Translation-More-Than-Once]
- [install-statement Statement #statement Cannot-Define-Statement-More-Than-Once]
+ [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/new-luxc/source/luxc/lang/extension/analysis.lux b/new-luxc/source/luxc/lang/extension/analysis.lux
index d034f2919..30f43acef 100644
--- a/new-luxc/source/luxc/lang/extension/analysis.lux
+++ b/new-luxc/source/luxc/lang/extension/analysis.lux
@@ -1,9 +1,19 @@
(.module:
lux
(lux (data [text]
- (coll [dict #+ Dict])))
- [//])
+ (coll [list "list/" Functor]
+ [dict #+ Dict])))
+ [//]
+ [/common]
+ [/host])
+
+(def: realize
+ (-> /common.Bundle (Dict Text //.Analysis))
+ (|>> dict.entries
+ (list/map (function [[name proc]] [name (proc name)]))
+ (dict.from-list text.Hash)))
(def: #export defaults
- (Dict Text //.Expression)
- (dict.new text.Hash))
+ (Dict Text //.Analysis)
+ (realize (dict.merge /common.procedures
+ /host.procedures)))
diff --git a/new-luxc/source/luxc/lang/extension/analysis/common.lux b/new-luxc/source/luxc/lang/extension/analysis/common.lux
new file mode 100644
index 000000000..079001b26
--- /dev/null
+++ b/new-luxc/source/luxc/lang/extension/analysis/common.lux
@@ -0,0 +1,419 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (concurrency [atom #+ Atom])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor]
+ [array]
+ [dict #+ Dict]))
+ [macro]
+ (macro [code])
+ (lang (type ["tc" check]))
+ [io])
+ (luxc ["&" lang]
+ (lang ["la" analysis]
+ (analysis ["&." common]
+ [".A" function]
+ [".A" case]
+ [".A" type])))
+ [///])
+
+(exception: #export Incorrect-Procedure-Arity)
+(exception: #export Invalid-Syntax)
+
+## [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)))
+
+(def: #export (wrong-arity proc expected actual)
+ (-> Text Nat Nat Text)
+ (format " Procedure: " (%t proc) "\n"
+ " Expected Arity: " (|> expected nat-to-int %i) "\n"
+ " Actual Arity: " (|> actual nat-to-int %i)))
+
+(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
+ [_ (&.infer outputT)
+ argsA (monad.map @
+ (function [[argT argC]]
+ (&.with-type argT
+ (analyse argC)))
+ (list.zip2 inputsT+ args))]
+ (wrap (la.procedure proc argsA)))
+ (&.throw Incorrect-Procedure-Arity (wrong-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
+ [[var-id varT] (&.with-type-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
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer (type (Either Text varT)))
+ opA (&.with-type (type (io.IO varT))
+ (analyse opC))]
+ (wrap (la.procedure proc (list opA))))
+
+ _
+ (&.throw Incorrect-Procedure-Arity (wrong-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.analyse-function analyse func-name arg-name body)
+
+ _
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args))))))
+
+(def: (lux//case proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list input [_ (#.Record branches)]))
+ (caseA.analyse-case analyse input branches)
+
+ _
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))
+
+(def: (lux//in-module proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval argsC+]
+ (case argsC+
+ (^ (list [_ (#.Text module-name)] exprC))
+ (&.with-current-module module-name
+ (analyse exprC))
+
+ _
+ (&.throw Invalid-Syntax (format "Procedure: " proc "\n"
+ " Inputs:" (|> argsC+
+ list.enumerate
+ (list/map (function [[idx argC]]
+ (format "\n " (%n idx) " " (%code argC))))
+ (text.join-with "")) "\n")))))
+
+(do-template [ ]
+ [(def: ( proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list typeC valueC))
+ ( analyse eval typeC valueC)
+
+ _
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))]
+
+ [lux//check typeA.analyse-check]
+ [lux//coerce typeA.analyse-coerce])
+
+(def: (lux//check//type proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list valueC))
+ (do macro.Monad
+ [_ (&.infer (type Type))
+ valueA (&.with-type Type
+ (analyse valueC))]
+ (wrap valueA))
+
+ _
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+
+(def: lux-procs
+ Bundle
+ (|> (dict.new text.Hash)
+ (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)
+ (install "log" (unary Text Unit))
+ (install "error" (unary Text Bottom))
+ (install "exit" (unary Int Bottom))
+ (install "current-time" (nullary Int)))))
+
+(def: bit-procs
+ Bundle
+ (<| (prefix "bit")
+ (|> (dict.new text.Hash)
+ (install "count" (unary Nat Nat))
+ (install "and" (binary Nat Nat Nat))
+ (install "or" (binary Nat Nat Nat))
+ (install "xor" (binary Nat Nat Nat))
+ (install "shift-left" (binary Nat Nat Nat))
+ (install "unsigned-shift-right" (binary Nat Nat Nat))
+ (install "shift-right" (binary Int Nat Int))
+ )))
+
+(def: nat-procs
+ Bundle
+ (<| (prefix "nat")
+ (|> (dict.new text.Hash)
+ (install "+" (binary Nat Nat Nat))
+ (install "-" (binary Nat Nat Nat))
+ (install "*" (binary Nat Nat Nat))
+ (install "/" (binary Nat Nat Nat))
+ (install "%" (binary Nat Nat Nat))
+ (install "=" (binary Nat Nat Bool))
+ (install "<" (binary Nat Nat Bool))
+ (install "min" (nullary Nat))
+ (install "max" (nullary Nat))
+ (install "to-int" (unary Nat Int))
+ (install "char" (unary Nat Text)))))
+
+(def: int-procs
+ Bundle
+ (<| (prefix "int")
+ (|> (dict.new text.Hash)
+ (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)))))
+
+(def: deg-procs
+ Bundle
+ (<| (prefix "deg")
+ (|> (dict.new text.Hash)
+ (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)
+ (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)
+ (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))))
+ (install "upper" (unary Text Text))
+ (install "lower" (unary Text Text))
+ )))
+
+(def: (array//get proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-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
+ [[var-id varT] (&.with-type-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
+ [[var-id varT] (&.with-type-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)
+ (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)
+ (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 "root2" (unary Frac Frac))
+ (install "root3" (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
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer (type (Atom varT)))
+ initA (&.with-type varT
+ (analyse initC))]
+ (wrap (la.procedure proc (list initA))))
+
+ _
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
+
+(def: (atom-read proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-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
+ [[var-id varT] (&.with-type-env tc.var)]
+ ((trinary (type (Atom varT)) varT varT Bool proc)
+ analyse eval args))))
+
+(def: atom-procs
+ Bundle
+ (<| (prefix "atom")
+ (|> (dict.new text.Hash)
+ (install "new" atom-new)
+ (install "read" atom-read)
+ (install "compare-and-swap" atom//compare-and-swap)
+ )))
+
+(def: process-procs
+ Bundle
+ (<| (prefix "process")
+ (|> (dict.new text.Hash)
+ (install "concurrency-level" (nullary Nat))
+ (install "future" (unary (type (io.IO Top)) Unit))
+ (install "schedule" (binary Nat (type (io.IO Top)) Unit))
+ )))
+
+(def: #export procedures
+ Bundle
+ (<| (prefix "lux")
+ (|> (dict.new text.Hash)
+ (dict.merge lux-procs)
+ (dict.merge bit-procs)
+ (dict.merge nat-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 process-procs)
+ (dict.merge io-procs))))
diff --git a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
new file mode 100644
index 000000000..dba0e3e66
--- /dev/null
+++ b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
@@ -0,0 +1,1243 @@
+(.module:
+ [lux #- char]
+ (lux (control [monad #+ do]
+ ["p" parser]
+ ["ex" exception #+ exception:])
+ (concurrency ["A" atom])
+ (data ["e" error]
+ [maybe]
+ [product]
+ [bool "bool/" Eq]
+ [text "text/" Eq]
+ (text format
+ ["l" lexer])
+ (coll [list "list/" Fold Functor Monoid]
+ [array]
+ [dict #+ Dict]))
+ [macro "macro/" Monad]
+ (macro [code]
+ ["s" syntax])
+ (lang [type]
+ (type ["tc" check]))
+ [host])
+ (luxc ["&" lang]
+ (lang ["&." host]
+ ["la" analysis]
+ (analysis ["&." common]
+ [".A" inference])))
+ ["@" //common]
+ [///]
+ )
+
+(exception: #export Wrong-Syntax)
+(def: (wrong-syntax procedure args)
+ (-> Text (List Code) Text)
+ (format "Procedure: " procedure "\n"
+ "Arguments: " (%code (code.tuple args))))
+
+(exception: #export JVM-Type-Is-Not-Class)
+
+(exception: #export Non-Interface)
+(exception: #export Non-Object)
+(exception: #export Non-Array)
+(exception: #export Non-Throwable)
+(exception: #export Non-JVM-Type)
+
+(exception: #export Unknown-Class)
+(exception: #export Primitives-Cannot-Have-Type-Parameters)
+(exception: #export Primitives-Are-Not-Objects)
+(exception: #export Invalid-Type-For-Array-Element)
+
+(exception: #export Unknown-Field)
+(exception: #export Mistaken-Field-Owner)
+(exception: #export Not-Virtual-Field)
+(exception: #export Not-Static-Field)
+(exception: #export Cannot-Set-Final-Field)
+
+(exception: #export No-Candidates)
+(exception: #export Too-Many-Candidates)
+
+(exception: #export Cannot-Cast)
+(def: (cannot-cast to from)
+ (-> Type Type Text)
+ (format "From: " (%type from) "\n"
+ " To: " (%type to)))
+
+(exception: #export Cannot-Possibly-Be-Instance)
+
+(exception: #export Cannot-Convert-To-Class)
+(exception: #export Cannot-Convert-To-Parameter)
+(exception: #export Cannot-Convert-To-Lux-Type)
+(exception: #export Unknown-Type-Var)
+(exception: #export Type-Parameter-Mismatch)
+(exception: #export Cannot-Correspond-Type-With-Class)
+
+(def: #export null-class Text "#Null")
+
+(do-template [ ]
+ [(def: #export Type (#.Primitive (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)
+ (@.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 [ ]
+ [(def:
+ @.Bundle
+ (<| (@.prefix )
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary ))
+ (@.install "-" (@.binary ))
+ (@.install "*" (@.binary ))
+ (@.install "/" (@.binary ))
+ (@.install "%" (@.binary ))
+ (@.install "=" (@.binary Boolean))
+ (@.install "<" (@.binary Boolean))
+ (@.install "and" (@.binary ))
+ (@.install "or" (@.binary ))
+ (@.install "xor" (@.binary ))
+ (@.install "shl" (@.binary Integer ))
+ (@.install "shr" (@.binary Integer ))
+ (@.install "ushr" (@.binary Integer ))
+ )))]
+
+ [int-procs "int" Integer]
+ [long-procs "long" Long]
+ )
+
+(do-template [ ]
+ [(def:
+ @.Bundle
+ (<| (@.prefix )
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary ))
+ (@.install "-" (@.binary ))
+ (@.install "*" (@.binary ))
+ (@.install "/" (@.binary ))
+ (@.install "%" (@.binary ))
+ (@.install "=" (@.binary Boolean))
+ (@.install "<" (@.binary Boolean))
+ )))]
+
+ [float-procs "float" Float]
+ [double-procs "double" Double]
+ )
+
+(def: char-procs
+ @.Bundle
+ (<| (@.prefix "char")
+ (|> (dict.new text.Hash)
+ (@.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)))
+
+(def: (array-length proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list arrayC))
+ (do macro.Monad
+ [_ (&.infer Nat)
+ [var-id varT] (&.with-type-env tc.var)
+ arrayA (&.with-type (type (Array varT))
+ (analyse arrayC))]
+ (wrap (la.procedure proc (list arrayA))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
+
+(def: (array-new proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list lengthC))
+ (do macro.Monad
+ [lengthA (&.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
+ (&.throw Non-Array (%type expectedT)))
+
+ (^ (#.Primitive "#Array" (list elemT)))
+ (recur elemT (n/inc level))
+
+ (#.Primitive class _)
+ (wrap [level class])
+
+ _
+ (&.throw Non-Array (%type expectedT)))))
+ _ (if (n/> +0 level)
+ (wrap [])
+ (&.throw Non-Array (%type expectedT)))]
+ (wrap (la.procedure proc (list (code.nat (n/dec level)) (code.text elem-class) lengthA))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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 []
+ ( env unquantified)
+ (check-jvm unquantified))
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (check-jvm outputT)
+
+ #.None
+ (&.throw Non-Object (%type objectT)))
+
+ _
+ (&.throw Non-Object (%type objectT))))
+
+(def: (check-object objectT)
+ (-> Type (Meta Text))
+ (do macro.Monad
+ [name (check-jvm objectT)]
+ (if (dict.contains? name boxes)
+ (&.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)
+ (&.throw Primitives-Cannot-Have-Type-Parameters name)
+ (macro/wrap [elemT name]))
+
+ _
+ (&.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
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer varT)
+ arrayA (&.with-type (type (Array varT))
+ (analyse arrayC))
+ ?elemT (&.with-type-env
+ (tc.read var-id))
+ [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (&.with-type Nat
+ (analyse idxC))]
+ (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer (type (Array varT)))
+ arrayA (&.with-type (type (Array varT))
+ (analyse arrayC))
+ ?elemT (&.with-type-env
+ (tc.read var-id))
+ [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (&.with-type Nat
+ (analyse idxC))
+ valueA (&.with-type valueT
+ (analyse valueC))]
+ (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
+
+(def: array-procs
+ @.Bundle
+ (<| (@.prefix "array")
+ (|> (dict.new text.Hash)
+ (@.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
+ [expectedT macro.expected-type
+ _ (check-object expectedT)]
+ (wrap (la.procedure proc (list))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args))))))
+
+(def: (object-null? proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list objectC))
+ (do macro.Monad
+ [_ (&.infer Bool)
+ [objectT objectA] (&common.with-unknown-type
+ (analyse objectC))
+ _ (check-object objectT)]
+ (wrap (la.procedure proc (list objectA))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
+
+(def: (object-synchronized proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list monitorC exprC))
+ (do macro.Monad
+ [[monitorT monitorA] (&common.with-unknown-type
+ (analyse monitorC))
+ _ (check-object monitorT)
+ exprA (analyse exprC)]
+ (wrap (la.procedure proc (list monitorA exprA))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
+
+(host.import java/lang/Object
+ (equals [Object] boolean))
+
+(host.import java/lang/ClassLoader)
+
+(host.import #long java/lang/reflect/Type
+ (getTypeName [] String))
+
+(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 boolean ClassLoader] #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
+ [class-loader &host.class-loader]
+ (case (Class::forName [name false class-loader])
+ (#e.Success [class])
+ (wrap class)
+
+ (#e.Error error)
+ (&.throw Unknown-Class name))))
+
+(def: (sub-class? super sub)
+ (-> Text Text (Meta Bool))
+ (do macro.Monad
+ [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
+ [_ (&.infer Bottom)
+ [exceptionT exceptionA] (&common.with-unknown-type
+ (analyse exceptionC))
+ exception-class (check-object exceptionT)
+ ? (sub-class? "java.lang.Throwable" exception-class)
+ _ (: (Meta Unit)
+ (if ?
+ (wrap [])
+ (&.throw Non-Throwable exception-class)))]
+ (wrap (la.procedure proc (list exceptionA))))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
+ [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
+ _ (load-class class)]
+ (wrap (la.procedure proc (list (code.text class)))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
+ [_ (&.infer Bool)
+ [objectT objectA] (&common.with-unknown-type
+ (analyse objectC))
+ object-class (check-object objectT)
+ ? (sub-class? class object-class)]
+ (if ?
+ (wrap (la.procedure proc (list (code.text class))))
+ (&.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
+
+(def: object-procs
+ @.Bundle
+ (<| (@.prefix "object")
+ (|> (dict.new text.Hash)
+ (@.install "null" object-null)
+ (@.install "null?" object-null?)
+ (@.install "synchronized" object-synchronized)
+ (@.install "throw" object-throw)
+ (@.install "class" object-class)
+ (@.install "instance?" object-instance?)
+ )))
+
+(def: type-descriptor
+ (-> java/lang/reflect/Type Text)
+ (java/lang/reflect/Type::getTypeName []))
+
+(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
+ (&.throw Cannot-Convert-To-Class (type-descriptor type))))
+
+(type: Mappings
+ (Dict Text Type))
+
+(def: fresh-mappings Mappings (dict.new text.Hash))
+
+(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
+ (&.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 Top)))
+
+ (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 (n/dec arity))
+ list.reverse
+ (list/map (|>> (n/* +2) n/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
+ [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)))
+ (&.throw JVM-Type-Is-Not-Class (type-descriptor raw))))
+
+ (host.instance? GenericArrayType java-type)
+ (do macro.Monad
+ [innerT (|> (:! GenericArrayType java-type)
+ (GenericArrayType::getGenericComponentType [])
+ (java-type-to-lux-type mappings))]
+ (wrap (#.Primitive "#Array" (list innerT))))
+
+ ## else
+ (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
+
+(type: Direction
+ #In
+ #Out)
+
+(def: (choose direction to from)
+ (-> Direction Text Text Text)
+ (case direction
+ #In to
+ #Out from))
+
+(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))
+ (&.throw Cannot-Correspond-Type-With-Class
+ (format "Class = " class-name "\n"
+ "Type = " (%type type)))
+
+ (not (n/= num-class-params num-type-params))
+ (&.throw Type-Parameter-Mismatch
+ (format "Expected: " (%i (nat-to-int num-class-params)) "\n"
+ " Actual: " (%i (nat-to-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)))
+ ))
+
+ _
+ (&.throw Non-JVM-Type (%type type))))
+
+(def: (cast direction to from)
+ (-> Direction Type Type (Meta [Text Type]))
+ (do macro.Monad
+ [to-name (check-jvm to)
+ from-name (check-jvm from)]
+ (cond (dict.contains? to-name boxes)
+ (let [box (maybe.assume (dict.get to-name boxes))]
+ (if (text/= box from-name)
+ (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))])
+ (&.throw Cannot-Cast (cannot-cast to from))))
+
+ (dict.contains? from-name boxes)
+ (let [box (maybe.assume (dict.get from-name boxes))]
+ (do @
+ [[_ castT] (cast direction to (#.Primitive box (list)))]
+ (wrap [(choose direction to-name from-name) castT])))
+
+ (text/= to-name from-name)
+ (wrap [(choose direction to-name from-name) from])
+
+ (text/= null-class from-name)
+ (wrap [(choose direction to-name from-name) to])
+
+ ## else
+ (do @
+ [to-class (load-class to-name)
+ from-class (load-class from-name)
+ _ (&.assert Cannot-Cast (cannot-cast to from)
+ (Class::isAssignableFrom [from-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 [java-type (Class::isAssignableFrom [class] to-class)])))
+ (list& (Class::getGenericSuperclass [] from-class)
+ (array.to-list (Class::getGenericInterfaces [] from-class))))]
+ (case (|> candiate-parents
+ (list.filter product.right)
+ (list/map product.left))
+ (#.Cons parent _)
+ (do @
+ [mapping (correspond-type-params from-class from)
+ parentT (java-type-to-lux-type mapping parent)
+ [_ castT] (cast direction to parentT)]
+ (wrap [(choose direction to-name from-name) castT]))
+
+ #.Nil
+ (&.throw Cannot-Cast (cannot-cast to from)))))))
+
+(def: (infer-out outputT)
+ (-> Type (Meta [Text Type]))
+ (do macro.Monad
+ [expectedT macro.expected-type
+ [unboxed castT] (cast #Out expectedT outputT)
+ _ (&.with-type-env
+ (tc.check expectedT castT))]
+ (wrap [unboxed castT])))
+
+(def: (find-field class-name field-name)
+ (-> Text Text (Meta [(Class Object) Field]))
+ (do macro.Monad
+ [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])
+ (&.throw Mistaken-Field-Owner
+ (format " Field: " field-name "\n"
+ " Owner Class: " (Class::getName [] owner) "\n"
+ "Target Class: " class-name "\n"))))
+
+ (#e.Error _)
+ (&.throw Unknown-Field (format class-name "#" field-name)))))
+
+(def: (static-field class-name field-name)
+ (-> Text Text (Meta [Type Bool]))
+ (do macro.Monad
+ [[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])])))
+ (&.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
+ [[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)]
+ _ (&.assert Type-Parameter-Mismatch
+ (format "Expected: " (%i (nat-to-int num-params)) "\n"
+ " Actual: " (%i (nat-to-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))))
+
+ _
+ (&.throw Non-Object (%type objectT))))
+ fieldT (java-type-to-lux-type mappings fieldJT)]
+ (wrap [fieldT (Modifier::isFinal [modifiers])]))
+ (&.throw Not-Virtual-Field (format class-name "#" field-name)))))
+
+(def: (analyse-object class analyse sourceC)
+ (-> Text &.Analyser Code (Meta [Type la.Analysis]))
+ (do macro.Monad
+ [target-class (load-class class)
+ targetT (java-type-to-lux-type fresh-mappings
+ (:! java/lang/reflect/Type
+ target-class))
+ [sourceT sourceA] (&common.with-unknown-type
+ (analyse sourceC))
+ [unboxed castT] (cast #Out targetT sourceT)
+ _ (&.assert Cannot-Cast (cannot-cast targetT sourceT)
+ (not (dict.contains? unboxed boxes)))]
+ (wrap [castT sourceA])))
+
+(def: (analyse-input analyse targetT sourceC)
+ (-> &.Analyser Type Code (Meta [Type Text la.Analysis]))
+ (do macro.Monad
+ [[sourceT sourceA] (&common.with-unknown-type
+ (analyse sourceC))
+ [unboxed castT] (cast #In targetT sourceT)]
+ (wrap [castT unboxed sourceA])))
+
+(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
+ [[fieldT final?] (static-field class field)
+ [unboxed castT] (infer-out fieldT)]
+ (wrap (la.procedure proc (list (code.text class) (code.text field)
+ (code.text unboxed)))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
+ [_ (&.infer Unit)
+ [fieldT final?] (static-field class field)
+ _ (&.assert Cannot-Set-Final-Field (format class "#" field)
+ (not final?))
+ [valueT unboxed valueA] (analyse-input analyse fieldT valueC)
+ _ (&.with-type-env
+ (tc.check fieldT valueT))]
+ (wrap (la.procedure proc (list (code.text class) (code.text field)
+ (code.text unboxed) valueA))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
+ [[objectT objectA] (analyse-object class analyse objectC)
+ [fieldT final?] (virtual-field class field objectT)
+ [unboxed castT] (infer-out fieldT)]
+ (wrap (la.procedure proc (list (code.text class) (code.text field)
+ (code.text unboxed) objectA))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
+ [[objectT objectA] (analyse-object class analyse objectC)
+ _ (&.infer objectT)
+ [fieldT final?] (virtual-field class field objectT)
+ _ (&.assert Cannot-Set-Final-Field (format class "#" field)
+ (not final?))
+ [valueT unboxed valueA] (analyse-input analyse fieldT valueC)]
+ (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
+
+ _
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-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
+ [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))]
+ (wrap (format componentP "[]")))
+
+ ## else
+ (&.throw Cannot-Convert-To-Parameter (type-descriptor 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
+ [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
+ [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) n/inc #.Bound))
+
+(def: (type-vars amount offset)
+ (-> Nat Nat (List Type))
+ (if (n/= +0 amount)
+ (list)
+ (|> (list.n/range offset (|> amount n/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))))]
+ (do macro.Monad
+ [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
+ [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
+ (&.throw No-Candidates (format class-name "#" method-name))
+
+ (#.Cons candidate #.Nil)
+ (|> candidate product.right (method-to-type method-type))
+
+ _
+ (&.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))))]
+ (do macro.Monad
+ [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
+ [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
+ (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")"))
+
+ (#.Cons candidate #.Nil)
+ (|> candidate product.right constructor-to-type)
+
+ _
+ (&.throw Too-Many-Candidates class-name))))
+
+(def: (decorate-inputs typesT inputsA)
+ (-> (List Text) (List la.Analysis) (List la.Analysis))
+ (|> inputsA
+ (list.zip2 (list/map code.text typesT))
+ (list/map (function [[type value]]
+ (la.product (list type value))))))
+
+(def: (sub-type-analyser analyse)
+ (-> &.Analyser &.Analyser)
+ (function [argC]
+ (do macro.Monad
+ [[argT argA] (&common.with-unknown-type
+ (analyse argC))
+ expectedT macro.expected-type
+ [unboxed castT] (cast #In expectedT argT)]
+ (wrap argA))))
+
+(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
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (methods class method #Static argsT)
+ [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la.procedure proc (list& (code.text class) (code.text method)
+ (code.text unboxed) (decorate-inputs argsT argsA)))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-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
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (methods class method #Virtual argsT)
+ [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
+ #let [[objectA argsA] (case allA
+ (#.Cons objectA argsA)
+ [objectA argsA]
+
+ _
+ (undefined))]
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la.procedure proc (list& (code.text class) (code.text method)
+ (code.text unboxed) objectA (decorate-inputs argsT argsA)))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+
+(def: (invoke//special proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Unit]])
+ (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
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (methods class method #Special argsT)
+ [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la.procedure proc (list& (code.text class) (code.text method)
+ (code.text unboxed) (decorate-inputs argsT argsA)))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-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
+ [#let [argsT (list/map product.left argsTC)]
+ class (load-class class-name)
+ _ (&.assert Non-Interface class-name
+ (Modifier::isInterface [(Class::getModifiers [] class)]))
+ [methodT exceptionsT] (methods class-name method #Interface argsT)
+ [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la.procedure proc
+ (list& (code.text class-name) (code.text method) (code.text unboxed)
+ (decorate-inputs argsT argsA)))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-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
+ [#let [argsT (list/map product.left argsTC)]
+ [methodT exceptionsT] (constructor-methods class argsT)
+ [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA)))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+
+(def: member-procs
+ @.Bundle
+ (<| (@.prefix "member")
+ (|> (dict.new text.Hash)
+ (dict.merge (<| (@.prefix "static")
+ (|> (dict.new text.Hash)
+ (@.install "get" static-get)
+ (@.install "put" static-put))))
+ (dict.merge (<| (@.prefix "virtual")
+ (|> (dict.new text.Hash)
+ (@.install "get" virtual-get)
+ (@.install "put" virtual-put))))
+ (dict.merge (<| (@.prefix "invoke")
+ (|> (dict.new text.Hash)
+ (@.install "static" invoke//static)
+ (@.install "virtual" invoke//virtual)
+ (@.install "special" invoke//special)
+ (@.install "interface" invoke//interface)
+ (@.install "constructor" invoke//constructor)
+ )))
+ )))
+
+(def: #export procedures
+ @.Bundle
+ (<| (@.prefix "jvm")
+ (|> (dict.new text.Hash)
+ (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/new-luxc/source/luxc/lang/extension/statement.lux b/new-luxc/source/luxc/lang/extension/statement.lux
index 6e9530f38..7cb404b13 100644
--- a/new-luxc/source/luxc/lang/extension/statement.lux
+++ b/new-luxc/source/luxc/lang/extension/statement.lux
@@ -126,10 +126,10 @@
_
(throw-invalid-statement procedure inputsC+))))]
- [lux//analysis //.Expression //.install-analysis]
- [lux//synthesis //.Expression //.install-synthesis]
- [lux//translation //.Expression //.install-translation]
- [lux//statement //.Statement //.install-statement])
+ [lux//analysis //.Analysis //.install-analysis]
+ [lux//synthesis //.Synthesis //.install-synthesis]
+ [lux//translation //.Translation //.install-translation]
+ [lux//statement //.Statement //.install-statement])
(def: #export defaults
(Dict Text //.Statement)
diff --git a/new-luxc/source/luxc/lang/extension/synthesis.lux b/new-luxc/source/luxc/lang/extension/synthesis.lux
index d034f2919..32d726796 100644
--- a/new-luxc/source/luxc/lang/extension/synthesis.lux
+++ b/new-luxc/source/luxc/lang/extension/synthesis.lux
@@ -5,5 +5,5 @@
[//])
(def: #export defaults
- (Dict Text //.Expression)
+ (Dict Text //.Synthesis)
(dict.new text.Hash))
diff --git a/new-luxc/source/luxc/lang/extension/translation.lux b/new-luxc/source/luxc/lang/extension/translation.lux
index d034f2919..663babdb6 100644
--- a/new-luxc/source/luxc/lang/extension/translation.lux
+++ b/new-luxc/source/luxc/lang/extension/translation.lux
@@ -5,5 +5,5 @@
[//])
(def: #export defaults
- (Dict Text //.Expression)
+ (Dict Text //.Translation)
(dict.new text.Hash))
diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
index f2f88904d..f737e81fc 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
@@ -21,7 +21,7 @@
["$d" def]
["$i" inst]))
["la" analysis]
- (analysis (procedure ["&." host]))
+ (extension (analysis ["&." host]))
["ls" synthesis]))
["@" //common])
--
cgit v1.2.3