diff options
Diffstat (limited to 'new-luxc')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/type.lux | 27 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/extension.lux | 114 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/extension/analysis.lux | 19 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/extension/analysis/common.lux | 448 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux | 1218 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis.lux | 8 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/procedure/common.lux | 324 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux | 546 |
8 files changed, 0 insertions, 2704 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux deleted file mode 100644 index 6d89dd5ef..000000000 --- a/new-luxc/source/luxc/lang/analysis/type.lux +++ /dev/null @@ -1,27 +0,0 @@ -(.module: - lux - (lux (control monad) - [macro] - (lang (type ["tc" check]))) - (luxc ["&" lang] - (lang ["la" analysis #+ Analysis]))) - -## These 2 analysers are somewhat special, since they require the -## means of evaluating Lux expressions at compile-time for the sake of -## computing Lux type values. -(def: #export (analyse-check analyse eval type value) - (-> &.Analyser &.Eval Code Code (Meta Analysis)) - (do macro.Monad<Meta> - [actualT (eval Type type) - #let [actualT (:! Type actualT)] - _ (&.infer actualT)] - (&.with-type actualT - (analyse value)))) - -(def: #export (analyse-coerce analyse eval type value) - (-> &.Analyser &.Eval Code Code (Meta Analysis)) - (do macro.Monad<Meta> - [actualT (eval Type type) - _ (&.infer (:! Type actualT))] - (&.with-type Any - (analyse value)))) diff --git a/new-luxc/source/luxc/lang/extension.lux b/new-luxc/source/luxc/lang/extension.lux deleted file mode 100644 index 254dd18ca..000000000 --- a/new-luxc/source/luxc/lang/extension.lux +++ /dev/null @@ -1,114 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data ["e" error] - [text] - (coll (dictionary ["dict" unordered #+ Dict]))) - [macro]) - [//] - (// ["la" analysis] - ["ls" synthesis])) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Unknown-Analysis] - [Unknown-Synthesis] - [Unknown-Translation] - [Unknown-Statement] - - [Cannot-Define-Analysis-More-Than-Once] - [Cannot-Define-Synthesis-More-Than-Once] - [Cannot-Define-Translation-More-Than-Once] - [Cannot-Define-Statement-More-Than-Once] - ) - -(type: #export Analysis - (-> (-> Code (Meta Code)) - (-> Type Code (Meta Any)) - (List Code) (Meta Code))) - -(type: #export Synthesis - (-> (-> la.Analysis ls.Synthesis) (List Code) Code)) - -(type: #export Syntheses (Dict Text Synthesis)) - -(type: #export Translation - (-> (List Code) (Meta Code))) - -(type: #export Statement - (-> (List Code) (Meta Any))) - -(type: #export Extensions - {#analysis (Dict Text Analysis) - #synthesis Syntheses - #translation (Dict Text Translation) - #statement (Dict Text Statement)}) - -(def: #export fresh - Extensions - {#analysis (dict.new text.Hash<Text>) - #synthesis (dict.new text.Hash<Text>) - #translation (dict.new text.Hash<Text>) - #statement (dict.new text.Hash<Text>)}) - -(def: get - (Meta Extensions) - (function (_ compiler) - (#e.Success [compiler - (|> compiler (get@ #.extensions) (:! Extensions))]))) - -(def: (set extensions) - (-> Extensions (Meta Any)) - (function (_ compiler) - (#e.Success [(set@ #.extensions (:! Nothing extensions) compiler) - []]))) - -(do-template [<name> <type> <category> <exception>] - [(def: #export (<name> name) - (-> Text (Meta <type>)) - (do macro.Monad<Meta> - [extensions ..get] - (case (dict.get name (get@ <category> extensions)) - (#.Some extension) - (wrap extension) - - #.None - (//.throw <exception> name))))] - - [find-analysis Analysis #analysis Unknown-Analysis] - [find-synthesis Synthesis #synthesis Unknown-Synthesis] - [find-translation Translation #translation Unknown-Translation] - [find-statement Statement #statement Unknown-Statement] - ) - -(do-template [<no> <all> <type> <category> <empty>] - [(def: #export <no> - <type> - <empty>) - - (def: #export <all> - (Meta <type>) - (|> ..get - (:: macro.Monad<Meta> map (get@ <category>))))] - - [no-syntheses all-syntheses Syntheses #synthesis (dict.new text.Hash<Text>)] - ) - -(do-template [<name> <type> <category> <exception>] - [(def: #export (<name> name extension) - (-> Text <type> (Meta Any)) - (do macro.Monad<Meta> - [extensions ..get - _ (//.assert <exception> name - (not (dict.contains? name (get@ <category> extensions)))) - _ (..set (update@ <category> (dict.put name extension) extensions))] - (wrap [])))] - - [install-analysis Analysis #analysis Cannot-Define-Analysis-More-Than-Once] - [install-synthesis Synthesis #synthesis Cannot-Define-Synthesis-More-Than-Once] - [install-translation Translation #translation Cannot-Define-Translation-More-Than-Once] - [install-statement Statement #statement Cannot-Define-Statement-More-Than-Once] - ) diff --git a/new-luxc/source/luxc/lang/extension/analysis.lux b/new-luxc/source/luxc/lang/extension/analysis.lux deleted file mode 100644 index 79fa3af88..000000000 --- a/new-luxc/source/luxc/lang/extension/analysis.lux +++ /dev/null @@ -1,19 +0,0 @@ -(.module: - lux - (lux (data [text] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ 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<Text>))) - -(def: #export defaults - (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 deleted file mode 100644 index f22cdcdd1..000000000 --- a/new-luxc/source/luxc/lang/extension/analysis/common.lux +++ /dev/null @@ -1,448 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (concurrency [atom #+ Atom]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - [array] - (dictionary ["dict" unordered #+ Dict]))) - [macro] - (macro [code]) - (lang (type ["tc" check])) - [io]) - (luxc ["&" lang] - (lang ["la" analysis] - (analysis ["&." common] - [".A" function] - [".A" case] - [".A" type]))) - [///]) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Incorrect-Procedure-Arity] - [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<Text>))) - -(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<Meta> - [_ (&.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<Meta> - [[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<Meta> - [[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 [<name> <analyser>] - [(def: (<name> proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list typeC valueC)) - (<analyser> 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<Meta> - [_ (&.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<Text>) - (install "is" lux//is) - (install "try" lux//try) - (install "function" lux//function) - (install "case" lux//case) - (install "check" lux//check) - (install "coerce" lux//coerce) - (install "check type" lux//check//type) - (install "in-module" lux//in-module))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash<Text>) - (install "log" (unary Text Any)) - (install "error" (unary Text Nothing)) - (install "exit" (unary Int Nothing)) - (install "current-time" (nullary Int))))) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary Nat Nat Nat)) - (install "or" (binary Nat Nat Nat)) - (install "xor" (binary Nat Nat Nat)) - (install "left-shift" (binary Nat Nat Nat)) - (install "logical-right-shift" (binary Nat Nat Nat)) - (install "arithmetic-right-shift" (binary Int Nat Int)) - ))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash<Text>) - (install "+" (binary Int Int Int)) - (install "-" (binary Int Int Int)) - (install "*" (binary Int Int Int)) - (install "/" (binary Int Int Int)) - (install "%" (binary Int Int Int)) - (install "=" (binary Int Int Bool)) - (install "<" (binary Int Int Bool)) - (install "min" (nullary Int)) - (install "max" (nullary Int)) - (install "to-nat" (unary Int Nat)) - (install "to-frac" (unary Int Frac)) - (install "char" (unary Int Text))))) - -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary Deg Deg Deg)) - (install "-" (binary Deg Deg Deg)) - (install "*" (binary Deg Deg Deg)) - (install "/" (binary Deg Deg Deg)) - (install "%" (binary Deg Deg Deg)) - (install "=" (binary Deg Deg Bool)) - (install "<" (binary Deg Deg Bool)) - (install "scale" (binary Deg Nat Deg)) - (install "reciprocal" (binary Deg Nat Deg)) - (install "min" (nullary Deg)) - (install "max" (nullary Deg)) - (install "to-frac" (unary Deg Frac))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash<Text>) - (install "+" (binary Frac Frac Frac)) - (install "-" (binary Frac Frac Frac)) - (install "*" (binary Frac Frac Frac)) - (install "/" (binary Frac Frac Frac)) - (install "%" (binary Frac Frac Frac)) - (install "=" (binary Frac Frac Bool)) - (install "<" (binary Frac Frac Bool)) - (install "smallest" (nullary Frac)) - (install "min" (nullary Frac)) - (install "max" (nullary Frac)) - (install "not-a-number" (nullary Frac)) - (install "positive-infinity" (nullary Frac)) - (install "negative-infinity" (nullary Frac)) - (install "to-deg" (unary Frac Deg)) - (install "to-int" (unary Frac Int)) - (install "encode" (unary Frac Text)) - (install "decode" (unary Text (type (Maybe Frac))))))) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash<Text>) - (install "=" (binary Text Text Bool)) - (install "<" (binary Text Text Bool)) - (install "concat" (binary Text Text Text)) - (install "index" (trinary Text Text Nat (type (Maybe Nat)))) - (install "size" (unary Text Nat)) - (install "hash" (unary Text Nat)) - (install "replace-once" (trinary Text Text Text Text)) - (install "replace-all" (trinary Text Text Text Text)) - (install "char" (binary Text Nat (type (Maybe Nat)))) - (install "clip" (trinary Text Nat Nat (type (Maybe Text)))) - ))) - -(def: (array//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad<Meta> - [[var-id varT] (&.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<Meta> - [[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<Meta> - [[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<Text>) - (install "new" (unary Nat Array)) - (install "get" array//get) - (install "put" array//put) - (install "remove" array//remove) - (install "size" (unary (type (Ex [a] (Array a))) Nat)) - ))) - -(def: math-procs - Bundle - (<| (prefix "math") - (|> (dict.new text.Hash<Text>) - (install "cos" (unary Frac Frac)) - (install "sin" (unary Frac Frac)) - (install "tan" (unary Frac Frac)) - (install "acos" (unary Frac Frac)) - (install "asin" (unary Frac Frac)) - (install "atan" (unary Frac Frac)) - (install "cosh" (unary Frac Frac)) - (install "sinh" (unary Frac Frac)) - (install "tanh" (unary Frac Frac)) - (install "exp" (unary Frac Frac)) - (install "log" (unary Frac Frac)) - (install "ceil" (unary Frac Frac)) - (install "floor" (unary Frac Frac)) - (install "round" (unary Frac Frac)) - (install "atan2" (binary Frac Frac Frac)) - (install "pow" (binary Frac Frac Frac)) - ))) - -(def: (atom-new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list initC)) - (do macro.Monad<Meta> - [[var-id varT] (&.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<Meta> - [[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<Meta> - [[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<Text>) - (install "new" atom-new) - (install "read" atom-read) - (install "compare-and-swap" atom//compare-and-swap) - ))) - -(type: (Box ! a) - (#.Primitive "#Box" (#.Cons ! (#.Cons a #.Nil)))) - -(def: (box//new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list initC)) - (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var) - _ (&.infer (type (All [!] (Box ! 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: (box//read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad<Meta> - [[thread-id threadT] (&.with-type-env tc.var) - [var-id varT] (&.with-type-env tc.var)] - ((unary (type (Box threadT varT)) varT proc) - analyse eval args)))) - -(def: (box//write proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad<Meta> - [[thread-id threadT] (&.with-type-env tc.var) - [var-id varT] (&.with-type-env tc.var)] - ((binary varT (type (Box threadT varT)) Any proc) - analyse eval args)))) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" box//new) - (install "read" box//read) - (install "write" box//write) - ))) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash<Text>) - (install "parallelism-level" (nullary Nat)) - (install "schedule" (binary Nat (type (io.IO Any)) Any)) - ))) - -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> (dict.new text.Hash<Text>) - (dict.merge lux-procs) - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge deg-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge array-procs) - (dict.merge math-procs) - (dict.merge atom-procs) - (dict.merge box-procs) - (dict.merge process-procs) - (dict.merge io-procs)))) diff --git a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux deleted file mode 100644 index 9ef06a4b1..000000000 --- a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux +++ /dev/null @@ -1,1218 +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<Bool>] - [text "text/" Eq<Text>] - (text format - ["l" lexer]) - (coll [list "list/" Fold<List> Functor<List> Monoid<List>] - [array] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>] - (macro [code] - ["s" syntax]) - (lang [type] - (type ["tc" check])) - [host]) - (luxc ["&" lang] - (lang ["&." host] - ["la" analysis] - (analysis ["&." common] - [".A" inference]))) - ["@" //common] - [///] - ) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Wrong-Syntax] - - [JVM-Type-Is-Not-Class] - - [Non-Interface] - [Non-Object] - [Non-Array] - [Non-Throwable] - [Non-JVM-Type] - - [Unknown-Class] - [Primitives-Cannot-Have-Type-Parameters] - [Primitives-Are-Not-Objects] - [Invalid-Type-For-Array-Element] - - [Unknown-Field] - [Mistaken-Field-Owner] - [Not-Virtual-Field] - [Not-Static-Field] - [Cannot-Set-Final-Field] - - [No-Candidates] - [Too-Many-Candidates] - - [Cannot-Cast] - - [Cannot-Possibly-Be-Instance] - - [Cannot-Convert-To-Class] - [Cannot-Convert-To-Parameter] - [Cannot-Convert-To-Lux-Type] - [Unknown-Type-Var] - [Type-Parameter-Mismatch] - [Cannot-Correspond-Type-With-Class] - ) - -(def: (wrong-syntax procedure args) - (-> Text (List Code) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code.tuple args)))) - -(do-template [<name> <class>] - [(def: #export <name> Type (#.Primitive <class> (list)))] - - ## Boxes - [Boolean "java.lang.Boolean"] - [Byte "java.lang.Byte"] - [Short "java.lang.Short"] - [Integer "java.lang.Integer"] - [Long "java.lang.Long"] - [Float "java.lang.Float"] - [Double "java.lang.Double"] - [Character "java.lang.Character"] - [String "java.lang.String"] - - ## Primitives - [boolean "boolean"] - [byte "byte"] - [short "short"] - [int "int"] - [long "long"] - [float "float"] - [double "double"] - [char "char"] - ) - -(def: conversion-procs - @.Bundle - (<| (@.prefix "convert") - (|> (dict.new text.Hash<Text>) - (@.install "double-to-float" (@.unary Double Float)) - (@.install "double-to-int" (@.unary Double Integer)) - (@.install "double-to-long" (@.unary Double Long)) - (@.install "float-to-double" (@.unary Float Double)) - (@.install "float-to-int" (@.unary Float Integer)) - (@.install "float-to-long" (@.unary Float Long)) - (@.install "int-to-byte" (@.unary Integer Byte)) - (@.install "int-to-char" (@.unary Integer Character)) - (@.install "int-to-double" (@.unary Integer Double)) - (@.install "int-to-float" (@.unary Integer Float)) - (@.install "int-to-long" (@.unary Integer Long)) - (@.install "int-to-short" (@.unary Integer Short)) - (@.install "long-to-double" (@.unary Long Double)) - (@.install "long-to-float" (@.unary Long Float)) - (@.install "long-to-int" (@.unary Long Integer)) - (@.install "long-to-short" (@.unary Long Short)) - (@.install "long-to-byte" (@.unary Long Byte)) - (@.install "char-to-byte" (@.unary Character Byte)) - (@.install "char-to-short" (@.unary Character Short)) - (@.install "char-to-int" (@.unary Character Integer)) - (@.install "char-to-long" (@.unary Character Long)) - (@.install "byte-to-long" (@.unary Byte Long)) - (@.install "short-to-long" (@.unary Short Long)) - ))) - -(do-template [<name> <prefix> <type>] - [(def: <name> - @.Bundle - (<| (@.prefix <prefix>) - (|> (dict.new text.Hash<Text>) - (@.install "+" (@.binary <type> <type> <type>)) - (@.install "-" (@.binary <type> <type> <type>)) - (@.install "*" (@.binary <type> <type> <type>)) - (@.install "/" (@.binary <type> <type> <type>)) - (@.install "%" (@.binary <type> <type> <type>)) - (@.install "=" (@.binary <type> <type> Boolean)) - (@.install "<" (@.binary <type> <type> Boolean)) - (@.install "and" (@.binary <type> <type> <type>)) - (@.install "or" (@.binary <type> <type> <type>)) - (@.install "xor" (@.binary <type> <type> <type>)) - (@.install "shl" (@.binary <type> Integer <type>)) - (@.install "shr" (@.binary <type> Integer <type>)) - (@.install "ushr" (@.binary <type> Integer <type>)) - )))] - - [int-procs "int" Integer] - [long-procs "long" Long] - ) - -(do-template [<name> <prefix> <type>] - [(def: <name> - @.Bundle - (<| (@.prefix <prefix>) - (|> (dict.new text.Hash<Text>) - (@.install "+" (@.binary <type> <type> <type>)) - (@.install "-" (@.binary <type> <type> <type>)) - (@.install "*" (@.binary <type> <type> <type>)) - (@.install "/" (@.binary <type> <type> <type>)) - (@.install "%" (@.binary <type> <type> <type>)) - (@.install "=" (@.binary <type> <type> Boolean)) - (@.install "<" (@.binary <type> <type> Boolean)) - )))] - - [float-procs "float" Float] - [double-procs "double" Double] - ) - -(def: char-procs - @.Bundle - (<| (@.prefix "char") - (|> (dict.new text.Hash<Text>) - (@.install "=" (@.binary Character Character Boolean)) - (@.install "<" (@.binary Character Character Boolean)) - ))) - -(def: #export boxes - (Dict Text Text) - (|> (list ["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) - (dict.from-list text.Hash<Text>))) - -(def: (array-length proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list arrayC)) - (do macro.Monad<Meta> - [_ (&.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<Meta> - [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 [<tag>] - (<tag> 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<Meta> - [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<Meta> - [[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<Meta> - [[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<Text>) - (@.install "length" array-length) - (@.install "new" array-new) - (@.install "read" array-read) - (@.install "write" array-write) - ))) - -(def: (object//null proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list)) - (do macro.Monad<Meta> - [expectedT macro.expected-type - _ (check-object expectedT)] - (wrap (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<Meta> - [_ (&.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<Meta> - [[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<Meta> - [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<Meta> - [super (load-class super) - sub (load-class sub)] - (wrap (Class::isAssignableFrom [sub] super)))) - -(def: (object//throw proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list exceptionC)) - (do macro.Monad<Meta> - [_ (&.infer Nothing) - [exceptionT exceptionA] (&common.with-unknown-type - (analyse exceptionC)) - exception-class (check-object exceptionT) - ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Meta Any) - (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<Meta> - [_ (&.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<Meta> - [_ (&.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: 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<Text>)) - -(def: (java-type-to-lux-type mappings java-type) - (-> Mappings java/lang/reflect/Type (Meta Type)) - (cond (host.instance? TypeVariable java-type) - (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] - (case (dict.get var-name mappings) - (#.Some var-type) - (macro/wrap var-type) - - #.None - (&.throw Unknown-Type-Var var-name))) - - (host.instance? WildcardType java-type) - (let [java-type (:! WildcardType java-type)] - (case [(array.read +0 (WildcardType::getUpperBounds [] java-type)) - (array.read +0 (WildcardType::getLowerBounds [] java-type))] - (^or [(#.Some bound) _] [_ (#.Some bound)]) - (java-type-to-lux-type mappings bound) - - _ - (macro/wrap Any))) - - (host.instance? Class java-type) - (let [java-type (:! (Class Object) java-type) - class-name (Class::getName [] java-type)] - (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) - +0 - (#.Primitive class-name (list)) - - arity - (|> (list.n/range +0 (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<Meta> - [paramsT (|> java-type - (ParameterizedType::getActualTypeArguments []) - array.to-list - (monad.map @ (java-type-to-lux-type mappings)))] - (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) - paramsT))) - (&.throw JVM-Type-Is-Not-Class (type-descriptor raw)))) - - (host.instance? GenericArrayType java-type) - (do macro.Monad<Meta> - [innerT (|> (:! GenericArrayType java-type) - (GenericArrayType::getGenericComponentType []) - (java-type-to-lux-type mappings))] - (wrap (#.Primitive "#Array" (list innerT)))) - - ## else - (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) - -(def: (correspond-type-params class type) - (-> (Class Object) Type (Meta Mappings)) - (case type - (#.Primitive name params) - (let [class-name (Class::getName [] class) - class-params (array.to-list (Class::getTypeParameters [] class)) - num-class-params (list.size class-params) - num-type-params (list.size params)] - (cond (not (text/= class-name name)) - (&.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<Text>))) - )) - - _ - (&.throw Non-JVM-Type (%type type)))) - -(def: (object//cast proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list valueC)) - (do macro.Monad<Meta> - [toT macro.expected-type - to-name (check-jvm toT) - [valueT valueA] (&common.with-unknown-type - (analyse valueC)) - from-name (check-jvm valueT) - can-cast? (: (Meta Bool) - (case [from-name to-name] - (^template [<primitive> <object>] - (^or [<primitive> <object>] - [<object> <primitive>]) - (do @ - [_ (&.infer (#.Primitive to-name (list)))] - (wrap true))) - (["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) - - _ - (do @ - [_ (&.assert Primitives-Are-Not-Objects from-name - (not (dict.contains? from-name boxes))) - _ (&.assert Primitives-Are-Not-Objects to-name - (not (dict.contains? to-name boxes))) - to-class (load-class to-name)] - (loop [[current-name currentT] [from-name valueT]] - (if (text/= to-name current-name) - (do @ - [_ (&.infer toT)] - (wrap true)) - (do @ - [current-class (load-class current-name) - _ (&.assert Cannot-Cast (format "From class/primitive: " current-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n") - (Class::isAssignableFrom [current-class] to-class)) - candiate-parents (monad.map @ - (function (_ java-type) - (do @ - [class-name (java-type-to-class java-type) - class (load-class class-name)] - (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)]))) - (list& (Class::getGenericSuperclass [] current-class) - (array.to-list (Class::getGenericInterfaces [] current-class))))] - (case (|> candiate-parents - (list.filter product.right) - (list/map product.left)) - (#.Cons [next-name nextJT] _) - (do @ - [mapping (correspond-type-params current-class currentT) - nextT (java-type-to-lux-type mapping nextJT)] - (recur [next-name nextT])) - - #.Nil - (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n"))) - ))))))] - (if can-cast? - (wrap (la.procedure proc (list (code.text from-name) - (code.text to-name) - valueA))) - (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n")))) - - _ - (&.throw Wrong-Syntax (wrong-syntax proc args))))) - -(def: object-procs - @.Bundle - (<| (@.prefix "object") - (|> (dict.new text.Hash<Text>) - (@.install "null" object//null) - (@.install "null?" object//null?) - (@.install "synchronized" object//synchronized) - (@.install "throw" object//throw) - (@.install "class" object//class) - (@.install "instance?" object//instance?) - (@.install "cast" object//cast) - ))) - -(def: (find-field class-name field-name) - (-> Text Text (Meta [(Class Object) Field])) - (do macro.Monad<Meta> - [class (load-class class-name)] - (case (Class::getDeclaredField [field-name] class) - (#e.Success field) - (let [owner (Field::getDeclaringClass [] field)] - (if (is? owner class) - (wrap [class field]) - (&.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<Meta> - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers [] fieldJ)]] - (if (Modifier::isStatic [modifiers]) - (let [fieldJT (Field::getGenericType [] fieldJ)] - (do @ - [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal [modifiers])]))) - (&.throw Not-Static-Field (format class-name "#" field-name))))) - -(def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Meta [Type Bool])) - (do macro.Monad<Meta> - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers [] fieldJ)]] - (if (not (Modifier::isStatic [modifiers])) - (do @ - [#let [fieldJT (Field::getGenericType [] fieldJ) - var-names (|> class - (Class::getTypeParameters []) - array.to-list - (list/map (TypeVariable::getName [])))] - mappings (: (Meta Mappings) - (case objectT - (#.Primitive _class-name _class-params) - (do @ - [#let [num-params (list.size _class-params) - num-vars (list.size var-names)] - _ (&.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<Text>)))) - - _ - (&.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: (static//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list classC fieldC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> - [[fieldT final?] (static-field class field)] - (wrap (la.procedure proc (list (code.text class) (code.text field))))) - - _ - (&.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<Meta> - [_ (&.infer Any) - [fieldT final?] (static-field class field) - _ (&.assert Cannot-Set-Final-Field (format class "#" field) - (not final?)) - valueA (&.with-type fieldT - (analyse valueC))] - (wrap (la.procedure proc (list (code.text class) (code.text field) 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<Meta> - [[objectT objectA] (&common.with-unknown-type - (analyse objectC)) - [fieldT final?] (virtual-field class field objectT)] - (wrap (la.procedure proc (list (code.text class) (code.text field) 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<Meta> - [[objectT objectA] (&common.with-unknown-type - (analyse objectC)) - _ (&.infer objectT) - [fieldT final?] (virtual-field class field objectT) - _ (&.assert Cannot-Set-Final-Field (format class "#" field) - (not final?)) - valueA (&.with-type fieldT - (analyse valueC))] - (wrap (la.procedure proc (list (code.text class) (code.text field) 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<Meta> - [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<Meta> - [parameters (|> (Method::getGenericParameterTypes [] method) - array.to-list - (monad.map @ java-type-to-parameter)) - #let [modifiers (Method::getModifiers [] method)]] - (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method)) - (text/= method-name (Method::getName [] method)) - (case #Static - #Special - (Modifier::isStatic [modifiers]) - - _ - true) - (case method-type - #Special - (not (or (Modifier::isInterface [(Class::getModifiers [] class)]) - (Modifier::isAbstract [modifiers]))) - - _ - true) - (n/= (list.size arg-classes) (list.size parameters)) - (list/fold (function (_ [expectedJC actualJC] prev) - (and prev - (text/= expectedJC actualJC))) - true - (list.zip2 arg-classes parameters)))))) - -(def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do macro.Monad<Meta> - [parameters (|> (Constructor::getGenericParameterTypes [] constructor) - array.to-list - (monad.map @ java-type-to-parameter))] - (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor)) - (n/= (list.size arg-classes) (list.size parameters)) - (list/fold (function (_ [expectedJC actualJC] prev) - (and prev - (text/= expectedJC actualJC))) - true - (list.zip2 arg-classes parameters)))))) - -(def: idx-to-bound - (-> Nat Type) - (|>> (n/* +2) 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<Text>))))] - (do macro.Monad<Meta> - [inputsT (|> (Method::getGenericParameterTypes [] method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method)) - exceptionsT (|> (Method::getGenericExceptionTypes [] method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type.univ-q num-all-tvars) - (type.function (case method-type - #Static - inputsT - - _ - (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) - inputsT))) - outputT)]] - (wrap [methodT exceptionsT])))) - -(def: (methods class-name method-name method-type arg-classes) - (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) - (do macro.Monad<Meta> - [class (load-class class-name) - candidates (|> class - (Class::getDeclaredMethods []) - array.to-list - (monad.map @ (function (_ method) - (do @ - [passes? (check-method class method-name method-type arg-classes method)] - (wrap [passes? method])))))] - (case (list.filter product.left candidates) - #.Nil - (&.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<Text>))))] - (do macro.Monad<Meta> - [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) - constructorT (<| (type.univ-q num-all-tvars) - (type.function inputsT) - objectT)]] - (wrap [constructorT exceptionsT])))) - -(def: (constructor-methods class-name arg-classes) - (-> Text (List Text) (Meta [Type (List Type)])) - (do macro.Monad<Meta> - [class (load-class class-name) - candidates (|> class - (Class::getConstructors []) - array.to-list - (monad.map @ (function (_ constructor) - (do @ - [passes? (check-constructor class arg-classes constructor)] - (wrap [passes? constructor])))))] - (case (list.filter product.left candidates) - #.Nil - (&.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: (invoke//static proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case (: (e.Error [Text Text (List [Text Code])]) - (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) - (#e.Success [class method argsTC]) - (do macro.Monad<Meta> - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (methods class method #Static argsT) - [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) - outputJC (check-jvm outputT)] - (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text outputJC) (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<Meta> - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJC (check-jvm outputT)] - (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text outputJC) 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]) Any]]) - (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) - (#e.Success [_ [class method objectC argsTC _]]) - (do macro.Monad<Meta> - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (methods class method #Special argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text outputJC) (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<Meta> - [#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 analyse methodT (list& objectC (list/map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (la.procedure proc - (list& (code.text class-name) (code.text method) (code.text outputJC) - (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<Meta> - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (constructor-methods class argsT) - [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] - (wrap (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<Text>) - (dict.merge (<| (@.prefix "static") - (|> (dict.new text.Hash<Text>) - (@.install "get" static//get) - (@.install "put" static//put)))) - (dict.merge (<| (@.prefix "virtual") - (|> (dict.new text.Hash<Text>) - (@.install "get" virtual//get) - (@.install "put" virtual//put)))) - (dict.merge (<| (@.prefix "invoke") - (|> (dict.new text.Hash<Text>) - (@.install "static" invoke//static) - (@.install "virtual" invoke//virtual) - (@.install "special" invoke//special) - (@.install "interface" invoke//interface) - (@.install "constructor" invoke//constructor) - ))) - ))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "jvm") - (|> (dict.new text.Hash<Text>) - (dict.merge conversion-procs) - (dict.merge int-procs) - (dict.merge long-procs) - (dict.merge float-procs) - (dict.merge double-procs) - (dict.merge char-procs) - (dict.merge array-procs) - (dict.merge object-procs) - (dict.merge member-procs) - ))) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux deleted file mode 100644 index 33c8aa063..000000000 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ /dev/null @@ -1,8 +0,0 @@ -(.module: - lux) - -(def: #export Arity Nat) - -(type: #export Synthesis Code) - -(type: #export Path Code) diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux deleted file mode 100644 index fba355a79..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux +++ /dev/null @@ -1,324 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data text/format - ["e" error] - [product] - (coll [array])) - ["r" math/random "r/" Monad<Random>] - [macro #+ Monad<Meta>] - (macro [code]) - (lang [type "type/" Eq<Type>]) - test) - (luxc ["&" lang] - (lang ["&." scope] - ["&." module] - ["~" analysis] - (analysis [".A" expression] - ["@." common]) - [".L" eval])) - (/// common) - (test/luxc common)) - -(do-template [<name> <success> <failure>] - [(def: (<name> procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (&.with-scope - (&.with-type output-type - (analyse (` ((~ (code.text procedure)) (~+ params)))))) - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - <success> - - (#e.Error error) - <failure>)))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(context: "Lux procedures" - (<| (times +100) - (do @ - [[primT primC] gen-primitive - [antiT antiC] (|> gen-primitive - (r.filter (|>> product.left (type/= primT) not)))] - ($_ seq - (test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bool)) - (test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bool)) - (test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ("lux function" (~' _) (~' _) (~ primC)))) - (type (Either Text primT)))) - )))) - -(context: "Bit procedures" - (<| (times +100) - (do @ - [subjectC (|> r.nat (:: @ map code.nat)) - signedC (|> r.int (:: @ map code.int)) - paramC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can count the number of 1 bits in a bit pattern." - (check-success+ "lux bit count" (list subjectC) Nat)) - (test "Can perform bit 'and'." - (check-success+ "lux bit and" (list subjectC paramC) Nat)) - (test "Can perform bit 'or'." - (check-success+ "lux bit or" (list subjectC paramC) Nat)) - (test "Can perform bit 'xor'." - (check-success+ "lux bit xor" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the left." - (check-success+ "lux bit left-shift" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the right." - (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat)) - (test "Can shift signed bit pattern to the right." - (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int)) - )))) - -(context: "Int procedures" - (<| (times +100) - (do @ - [subjectC (|> r.int (:: @ map code.int)) - paramC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can add integers." - (check-success+ "lux int +" (list subjectC paramC) Int)) - (test "Can subtract integers." - (check-success+ "lux int -" (list subjectC paramC) Int)) - (test "Can multiply integers." - (check-success+ "lux int *" (list subjectC paramC) Int)) - (test "Can divide integers." - (check-success+ "lux int /" (list subjectC paramC) Int)) - (test "Can calculate remainder of integers." - (check-success+ "lux int %" (list subjectC paramC) Int)) - (test "Can test equality of integers." - (check-success+ "lux int =" (list subjectC paramC) Bool)) - (test "Can compare integers." - (check-success+ "lux int <" (list subjectC paramC) Bool)) - (test "Can obtain minimum integer." - (check-success+ "lux int min" (list) Int)) - (test "Can obtain maximum integer." - (check-success+ "lux int max" (list) Int)) - (test "Can convert integer to natural number." - (check-success+ "lux int to-nat" (list subjectC) Nat)) - (test "Can convert integer to frac number." - (check-success+ "lux int to-frac" (list subjectC) Frac)) - (test "Can convert integer to text." - (check-success+ "lux int char" (list subjectC) Text)) - )))) - -(context: "Frac procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac)) - encodedC (|> (r.text +5) (:: @ map code.text))] - ($_ seq - (test "Can add frac numbers." - (check-success+ "lux frac +" (list subjectC paramC) Frac)) - (test "Can subtract frac numbers." - (check-success+ "lux frac -" (list subjectC paramC) Frac)) - (test "Can multiply frac numbers." - (check-success+ "lux frac *" (list subjectC paramC) Frac)) - (test "Can divide frac numbers." - (check-success+ "lux frac /" (list subjectC paramC) Frac)) - (test "Can calculate remainder of frac numbers." - (check-success+ "lux frac %" (list subjectC paramC) Frac)) - (test "Can test equality of frac numbers." - (check-success+ "lux frac =" (list subjectC paramC) Bool)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list subjectC paramC) Bool)) - (test "Can obtain minimum frac number." - (check-success+ "lux frac min" (list) Frac)) - (test "Can obtain maximum frac number." - (check-success+ "lux frac max" (list) Frac)) - (test "Can obtain smallest frac number." - (check-success+ "lux frac smallest" (list) Frac)) - (test "Can obtain not-a-number." - (check-success+ "lux frac not-a-number" (list) Frac)) - (test "Can obtain positive infinity." - (check-success+ "lux frac positive-infinity" (list) Frac)) - (test "Can obtain negative infinity." - (check-success+ "lux frac negative-infinity" (list) Frac)) - (test "Can convert frac number to integer." - (check-success+ "lux frac to-int" (list subjectC) Int)) - (test "Can convert frac number to text." - (check-success+ "lux frac encode" (list subjectC) Text)) - (test "Can convert text to frac number." - (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) - )))) - -(context: "Text procedures" - (<| (times +100) - (do @ - [subjectC (|> (r.text +5) (:: @ map code.text)) - paramC (|> (r.text +5) (:: @ map code.text)) - replacementC (|> (r.text +5) (:: @ map code.text)) - fromC (|> r.nat (:: @ map code.nat)) - toC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can test text equality." - (check-success+ "lux text =" (list subjectC paramC) Bool)) - (test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list subjectC paramC) Bool)) - (test "Can concatenate one text to another." - (check-success+ "lux text concat" (list subjectC paramC) Text)) - (test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) - (test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (test "Can calculate a hash code for text." - (check-success+ "lux text hash" (list subjectC) Nat)) - (test "Can replace a text inside of a larger one (once)." - (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) - (test "Can replace a text inside of a larger one (all times)." - (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) - (test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat)))) - (test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text)))) - )))) - -(context: "Array procedures" - (<| (times +100) - (do @ - [[elemT elemC] gen-primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.text +5) - #let [arrayT (type (Array elemT)) - g!array (code.local-symbol var-name) - array-operation (function (_ output-type code) - (|> (&scope.with-scope "" - (&scope.with-local [var-name arrayT] - (&.with-type output-type - (analyse code)))) - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - true - - (#e.Error error) - false)))]] - ($_ seq - (test "Can create arrays." - (check-success+ "lux array new" (list sizeC) arrayT)) - (test "Can get a value inside an array." - (array-operation (type (Maybe elemT)) - (` ("lux array get" (~ g!array) (~ idxC))))) - (test "Can put a value inside an array." - (array-operation arrayT - (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) - (test "Can remove a value from an array." - (array-operation arrayT - (` ("lux array remove" (~ g!array) (~ idxC))))) - (test "Can query the size of an array." - (array-operation Nat - (` ("lux array size" (~ g!array))))) - )))) - -(context: "Math procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac))] - (with-expansions [<unary> (do-template [<proc> <desc>] - [(test (format "Can calculate " <desc> ".") - (check-success+ <proc> (list subjectC) Frac))] - - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"]) - <binary> (do-template [<proc> <desc>] - [(test (format "Can calculate " <desc> ".") - (check-success+ <proc> (list subjectC paramC) Frac))] - - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"])] - ($_ seq - <unary> - <binary>))))) - -(context: "Atom procedures" - (<| (times +100) - (do @ - [[elemT elemC] gen-primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.text +5) - #let [atomT (type (atom.Atom elemT))]] - ($_ seq - (test "Can create atomic reference." - (check-success+ "lux atom new" (list elemC) atomT)) - (test "Can read the value of an atomic reference." - (|> (&scope.with-scope "" - (&scope.with-local [var-name atomT] - (&.with-type elemT - (analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - (test "Can swap the value of an atomic reference." - (|> (&scope.with-scope "" - (&scope.with-local [var-name atomT] - (&.with-type Bool - (analyse (` ("lux atom compare-and-swap" - (~ (code.symbol ["" var-name])) - (~ elemC) - (~ elemC))))))) - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - )))) - -(context: "Process procedures" - (<| (times +100) - (do @ - [[primT primC] gen-primitive - timeC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can query the level of concurrency." - (check-success+ "lux process parallelism-level" (list) Nat)) - (test "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "lux process schedule" - (list timeC - (` ("lux function" (~' _) (~' _) (~ primC)))) - Any)) - )))) - -(context: "IO procedures" - (<| (times +100) - (do @ - [logC (|> (r.text +5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Any)) - (test "Can throw a run-time error." - (check-success+ "lux io error" (list logC) Nothing)) - (test "Can exit the program." - (check-success+ "lux io exit" (list exitC) Nothing)) - (test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux deleted file mode 100644 index 3d0c76777..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux +++ /dev/null @@ -1,546 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data ["e" error] - [product] - [maybe] - [text "text/" Eq<Text>] - text/format - (coll [array] - [list "list/" Fold<List>] - (dictionary ["dict" unordered]))) - ["r" math/random "r/" Monad<Random>] - [macro #+ Monad<Meta>] - (macro [code]) - (lang [type]) - test) - (luxc ["&" lang] - (lang ["&." scope] - ["&." module] - ["~" analysis] - (analysis [".A" expression] - ["@." common]) - (translation (jvm ["@." runtime])) - (extension (analysis ["@." host])) - [".L" eval])) - (/// common) - (test/luxc common)) - -(do-template [<name> <success> <failure>] - [(def: (<name> procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (do Monad<Meta> - [runtime-bytecode @runtime.translate] - (&.with-scope - (&.with-type output-type - ((expressionA.analyser evalL.eval) - (` ((~ (code.text procedure)) (~+ params))))))) - (&.with-current-module "") - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - <success> - - (#e.Error error) - <failure>)))] - - [success true false] - [failure false true] - ) - -(do-template [<name> <success> <failure>] - [(def: (<name> syntax output-type) - (-> Code Type Bool) - (|> (do Monad<Meta> - [runtime-bytecode @runtime.translate] - (&.with-scope - (&.with-type output-type - (expressionA.analyser evalL.eval syntax)))) - (&.with-current-module "") - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - <success> - - (#e.Error error) - <failure>)))] - - [success' true false] - [failure' false true] - ) - -(context: "Conversions [double + float]." - (with-expansions [<conversions> (do-template [<procedure> <from> <to>] - [(test (format <procedure> " SUCCESS") - (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>)) - (test (format <procedure> " FAILURE") - (failure <procedure> (list (' [])) <to>))] - - ["jvm convert double-to-float" "java.lang.Double" @host.Float] - ["jvm convert double-to-int" "java.lang.Double" @host.Integer] - ["jvm convert double-to-long" "java.lang.Double" @host.Long] - ["jvm convert float-to-double" "java.lang.Float" @host.Double] - ["jvm convert float-to-int" "java.lang.Float" @host.Integer] - ["jvm convert float-to-long" "java.lang.Float" @host.Long] - )] - ($_ seq - <conversions> - ))) - -(context: "Conversions [int]." - (with-expansions [<conversions> (do-template [<procedure> <from> <to>] - [(test (format <procedure> " SUCCESS") - (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>)) - (test (format <procedure> " FAILURE") - (failure <procedure> (list (' [])) <to>))] - - ["jvm convert int-to-byte" "java.lang.Integer" @host.Byte] - ["jvm convert int-to-char" "java.lang.Integer" @host.Character] - ["jvm convert int-to-double" "java.lang.Integer" @host.Double] - ["jvm convert int-to-float" "java.lang.Integer" @host.Float] - ["jvm convert int-to-long" "java.lang.Integer" @host.Long] - ["jvm convert int-to-short" "java.lang.Integer" @host.Short] - )] - ($_ seq - <conversions> - ))) - -(context: "Conversions [long]." - (with-expansions [<conversions> (do-template [<procedure> <from> <to>] - [(test (format <procedure> " SUCCESS") - (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>)) - (test (format <procedure> " FAILURE") - (failure <procedure> (list (' [])) <to>))] - - ["jvm convert long-to-double" "java.lang.Long" @host.Double] - ["jvm convert long-to-float" "java.lang.Long" @host.Float] - ["jvm convert long-to-int" "java.lang.Long" @host.Integer] - ["jvm convert long-to-short" "java.lang.Long" @host.Short] - ["jvm convert long-to-byte" "java.lang.Long" @host.Byte] - )] - ($_ seq - <conversions> - ))) - -(context: "Conversions [char + byte + short]." - (with-expansions [<conversions> (do-template [<procedure> <from> <to>] - [(test (format <procedure> " SUCCESS") - (success <procedure> (list (' ("lux coerce" (+0 <from> (+0)) []))) <to>)) - (test (format <procedure> " FAILURE") - (failure <procedure> (list (' [])) <to>))] - - ["jvm convert char-to-byte" "java.lang.Character" @host.Byte] - ["jvm convert char-to-short" "java.lang.Character" @host.Short] - ["jvm convert char-to-int" "java.lang.Character" @host.Integer] - ["jvm convert char-to-long" "java.lang.Character" @host.Long] - ["jvm convert byte-to-long" "java.lang.Byte" @host.Long] - ["jvm convert short-to-long" "java.lang.Short" @host.Long] - )] - ($_ seq - <conversions> - ))) - -(do-template [<domain> <boxed> <type>] - [(context: (format "Arithmetic " "[" <domain> "].") - (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] - [(test <procedure> - (success <procedure> - (list (' ("lux coerce" (+0 <subject> (+0)) [])) - (' ("lux coerce" (+0 <param> (+0)) []))) - <output>))] - - [(format "jvm " <domain> " +") <boxed> <boxed> <type>] - [(format "jvm " <domain> " -") <boxed> <boxed> <type>] - [(format "jvm " <domain> " *") <boxed> <boxed> <type>] - [(format "jvm " <domain> " /") <boxed> <boxed> <type>] - [(format "jvm " <domain> " %") <boxed> <boxed> <type>] - )] - ($_ seq - <instructions> - ))) - - (context: (format "Order " "[" <domain> "].") - (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] - [(test <procedure> - (success <procedure> - (list (' ("lux coerce" (+0 <subject> (+0)) [])) - (' ("lux coerce" (+0 <param> (+0)) []))) - <output>))] - - [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] - )] - ($_ seq - <instructions> - ))) - - (context: (format "Bitwise " "[" <domain> "].") - (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] - [(test <procedure> - (success <procedure> - (list (' ("lux coerce" (+0 <subject> (+0)) [])) - (' ("lux coerce" (+0 <param> (+0)) []))) - <output>))] - - [(format "jvm " <domain> " and") <boxed> <boxed> <type>] - [(format "jvm " <domain> " or") <boxed> <boxed> <type>] - [(format "jvm " <domain> " xor") <boxed> <boxed> <type>] - [(format "jvm " <domain> " shl") <boxed> "java.lang.Integer" <type>] - [(format "jvm " <domain> " shr") <boxed> "java.lang.Integer" <type>] - [(format "jvm " <domain> " ushr") <boxed> "java.lang.Integer" <type>] - )] - ($_ seq - <instructions> - )))] - - - ["int" "java.lang.Integer" @host.Integer] - ["long" "java.lang.Long" @host.Long] - ) - -(do-template [<domain> <boxed> <type>] - [(context: (format "Arithmetic " "[" <domain> "].") - (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] - [(test <procedure> - (success <procedure> - (list (' ("lux coerce" (+0 <subject> (+0)) [])) - (' ("lux coerce" (+0 <param> (+0)) []))) - <output>))] - - [(format "jvm " <domain> " +") <boxed> <boxed> <type>] - [(format "jvm " <domain> " -") <boxed> <boxed> <type>] - [(format "jvm " <domain> " *") <boxed> <boxed> <type>] - [(format "jvm " <domain> " /") <boxed> <boxed> <type>] - [(format "jvm " <domain> " %") <boxed> <boxed> <type>] - )] - ($_ seq - <instructions> - ))) - - (context: (format "Order " "[" <domain> "].") - (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] - [(test <procedure> - (success <procedure> - (list (' ("lux coerce" (+0 <subject> (+0)) [])) - (' ("lux coerce" (+0 <param> (+0)) []))) - <output>))] - - [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] - )] - ($_ seq - <instructions> - )))] - - - ["float" "java.lang.Float" @host.Float] - ["double" "java.lang.Double" @host.Double] - ) - -(do-template [<domain> <boxed> <type>] - [(context: (format "Order " "[" <domain> "].") - (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>] - [(test <procedure> - (success <procedure> - (list (' ("lux coerce" (+0 <subject> (+0)) [])) - (' ("lux coerce" (+0 <param> (+0)) []))) - <output>))] - - [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] - )] - ($_ seq - <instructions> - )))] - - - ["char" "java.lang.Character" @host.Character] - ) - -(def: array-type - (r.Random [Text Text]) - (let [entries (dict.entries @host.boxes) - num-entries (list.size entries)] - (do r.Monad<Random> - [choice (|> r.nat (:: @ map (n/% (n/inc num-entries)))) - #let [[unboxed boxed] (: [Text Text] - (|> entries - (list.nth choice) - (maybe.default ["java.lang.Object" "java.lang.Object"])))]] - (wrap [unboxed boxed])))) - -(context: "Array." - (<| (times +100) - (do @ - [#let [cap (|>> (n/% +10) (n/max +1))] - [unboxed boxed] array-type - size (|> r.nat (:: @ map cap)) - idx (|> r.nat (:: @ map (n/% size))) - level (|> r.nat (:: @ map cap)) - #let [unboxedT (#.Primitive unboxed (list)) - arrayT (#.Primitive "#Array" (list unboxedT)) - arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0))) - ("jvm array new" (~ (code.nat size))))) - boxedT (#.Primitive boxed (list)) - boxedTC (` (+0 (~ (code.text boxed)) (+0))) - multi-arrayT (list/fold (function (_ _ innerT) - (|> innerT (list) (#.Primitive "#Array"))) - boxedT - (list.n/range +1 level))]] - ($_ seq - (test "jvm array new" - (success "jvm array new" - (list (code.nat size)) - arrayT)) - (test "jvm array new (no nesting)" - (failure "jvm array new" - (list (code.nat size)) - unboxedT)) - (test "jvm array new (nested/multi-level)" - (success "jvm array new" - (list (code.nat size)) - multi-arrayT)) - (test "jvm array length" - (success "jvm array length" - (list arrayC) - Nat)) - (test "jvm array read" - (success' (` ("jvm object cast" - ("jvm array read" (~ arrayC) (~ (code.nat idx))))) - boxedT)) - (test "jvm array write" - (success "jvm array write" - (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) - arrayT)) - )))) - -(def: throwables - (List Text) - (list "java.lang.Throwable" - "java.lang.Error" - "java.io.IOError" - "java.lang.VirtualMachineError" - "java.lang.Exception" - "java.io.IOException" - "java.lang.RuntimeException")) - -(context: "Object." - (<| (times +100) - (do @ - [[unboxed boxed] array-type - [!unboxed !boxed] (|> array-type - (r.filter (function (_ [!unboxed !boxed]) - (not (text/= boxed !boxed))))) - #let [boxedT (#.Primitive boxed (list)) - boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) - ("jvm object null"))) - !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) - ("jvm object null"))) - unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) - ("jvm object null")))] - throwable (|> r.nat - (:: @ map (n/% (n/inc (list.size throwables)))) - (:: @ map (function (_ idx) - (|> throwables - (list.nth idx) - (maybe.default "java.lang.Object"))))) - #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0)) - ("jvm object null")))]] - ($_ seq - (test "jvm object null" - (success "jvm object null" - (list) - (#.Primitive boxed (list)))) - (test "jvm object null (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object null" - (list) - (#.Primitive unboxed (list))))) - (test "jvm object null?" - (success "jvm object null?" - (list boxedC) - Bool)) - (test "jvm object synchronized" - (success "jvm object synchronized" - (list boxedC boxedC) - boxedT)) - (test "jvm object synchronized (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object synchronized" - (list unboxedC boxedC) - boxedT))) - (test "jvm object throw" - (or (text/= "java.lang.Object" throwable) - (success "jvm object throw" - (list throwableC) - Nothing))) - (test "jvm object class" - (success "jvm object class" - (list (code.text boxed)) - (#.Primitive "java.lang.Class" (list boxedT)))) - (test "jvm object instance?" - (success "jvm object instance?" - (list (code.text boxed) - boxedC) - Bool)) - (test "jvm object instance? (lineage)" - (success "jvm object instance?" - (list (' "java.lang.Object") - boxedC) - Bool)) - (test "jvm object instance? (no lineage)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object instance?" - (list (code.text boxed) - !boxedC) - Bool))) - )))) - -(context: "Member [Static Field]." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.io.PrintStream" (list)))) - (test "jvm member static get (inheritance out)" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member static put" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (final)" - (failure "jvm member static put" - (list (code.text "java.lang.System") - (code.text "out") - (`' ("lux check" (+0 "java.io.PrintStream" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (inheritance in)" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("jvm object cast" - ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) - ("jvm object null"))))) - Any)) - )) - -(context: "Member [Virtual Field]." - ($_ seq - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.String" (list)))) - (test "jvm member virtual get (inheritance out)" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "java.lang.String" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (primitive "org.omg.CORBA.ValueMember"))) - (test "jvm member virtual put (final)" - (failure "jvm member virtual put" - (list (code.text "javax.swing.text.html.parser.DTD") - (code.text "applet") - (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) - ("jvm object null")))) - (primitive "javax.swing.text.html.parser.DTD"))) - (test "jvm member virtual put (inheritance in)" - (success "jvm member virtual put" - (list (code.text "java.awt.GridBagConstraints") - (code.text "insets") - (`' ("jvm object cast" - ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) - ("jvm object null")))) - (primitive "java.awt.GridBagConstraints"))) - )) - -(context: "Boxing/Unboxing." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.util.GregorianCalendar") - (code.text "AD")) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("jvm object cast" - ("lux check" (+0 "java.lang.Integer" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (primitive "javax.accessibility.AccessibleAttributeSequence"))) - )) - -(context: "Member [Method]." - (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) - +123)) - intC (`' ("jvm convert long-to-int" (~ longC))) - stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) - "YOLO")) - objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) - ("jvm member invoke constructor" "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])))] - ($_ seq - (test "jvm member invoke static" - (success' (` ("jvm member invoke static" - "java.lang.Long" "decode" - ["java.lang.String" (~ stringC)])) - (#.Primitive "java.lang.Long" (list)))) - (test "jvm member invoke virtual" - (success' (` ("jvm object cast" - ("jvm member invoke virtual" - "java.lang.Object" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke special" - (success' (` ("jvm object cast" - ("jvm member invoke special" - "java.lang.Long" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke interface" - (success' (` ("jvm object cast" - ("jvm member invoke interface" - "java.util.Collection" "add" - ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke constructor" - (success' (` ("jvm member invoke constructor" - "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])) - (All [a] (#.Primitive "java.util.ArrayList" (list a))))) - ))) |