From 72950a540be3dc49a107700c77c0195db16a4f58 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 23 May 2018 02:04:47 -0400 Subject: - Migrated special-form analysis to stdlib. --- stdlib/source/lux/lang/analysis.lux | 17 +- stdlib/source/lux/lang/analysis/expression.lux | 11 +- stdlib/source/lux/lang/extension.lux | 113 ++ stdlib/source/lux/lang/extension/analysis.lux | 16 + .../source/lux/lang/extension/analysis/common.lux | 444 +++++++ .../lux/lang/extension/analysis/host.jvm.lux | 1224 ++++++++++++++++++++ stdlib/source/lux/lang/init.lux | 31 +- stdlib/source/lux/lang/synthesis.lux | 8 + .../test/lux/lang/analysis/procedure/common.lux | 316 +++++ .../test/lux/lang/analysis/procedure/host.jvm.lux | 541 +++++++++ 10 files changed, 2700 insertions(+), 21 deletions(-) create mode 100644 stdlib/source/lux/lang/extension.lux create mode 100644 stdlib/source/lux/lang/extension/analysis.lux create mode 100644 stdlib/source/lux/lang/extension/analysis/common.lux create mode 100644 stdlib/source/lux/lang/extension/analysis/host.jvm.lux create mode 100644 stdlib/source/lux/lang/synthesis.lux create mode 100644 stdlib/test/test/lux/lang/analysis/procedure/common.lux create mode 100644 stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 0b48f803d..324f12b3e 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -1,5 +1,5 @@ (.module: - lux + [lux #- nat int deg] (lux [function] (data (coll [list "list/" Fold])))) @@ -46,7 +46,20 @@ (#Apply Analysis Analysis) (#Variable Variable) (#Constant Ident) - (#Special (Special Text))) + (#Special (Special Analysis))) + +(do-template [ ] + [(def: #export + (-> Analysis) + (|>> #Primitive))] + + [bool Bool #Bool] + [nat Nat #Nat] + [int Int #Int] + [deg Deg #Deg] + [frac Frac #Frac] + [text Text #Text] + ) (type: #export (Variant a) {#lefts Nat diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux index da1b27a10..325394e73 100644 --- a/stdlib/source/lux/lang/analysis/expression.lux +++ b/stdlib/source/lux/lang/analysis/expression.lux @@ -15,8 +15,7 @@ [".A" structure] [".A" reference]) ## [".L" macro] - ## [".L" extension] - ))) + [".L" extension]))) (exception: #export (macro-expansion-failed {message Text}) message) @@ -80,10 +79,10 @@ (#.Symbol reference) (referenceA.reference reference) - ## (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) - ## (do macro.Monad - ## [procedure (extensionL.find-analysis proc-name)] - ## (procedure analyse eval proc-args)) + (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) + (do macro.Monad + [procedure (extensionL.find-analysis proc-name)] + (procedure analyse eval proc-args)) ## (^ (#.Form (list& func args))) ## (do macro.Monad diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux new file mode 100644 index 000000000..03fd81d71 --- /dev/null +++ b/stdlib/source/lux/lang/extension.lux @@ -0,0 +1,113 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [text] + (coll (dictionary ["dict" unordered #+ Dict]))) + [macro]) + [// #+ Eval] + (// [".L" analysis #+ Analyser] + [".L" synthesis])) + +(do-template [] + [(exception: #export ( {message Text}) + message)] + + [unknown-analysis] + [unknown-synthesis] + [unknown-translation] + [unknown-statement] + + [cannot-define-analysis-more-than-once] + [cannot-define-synthesis-more-than-once] + [cannot-define-translation-more-than-once] + [cannot-define-statement-more-than-once] + ) + +(type: #export Analysis + (-> Analyser Eval (List Code) (Meta analysisL.Analysis))) + +(type: #export Synthesis + (-> (-> analysisL.Analysis synthesisL.Synthesis) (List Code) Code)) + +(type: #export Translation + (-> (List Code) (Meta Code))) + +(type: #export Statement + (-> (List Code) (Meta Any))) + +(type: #export (Extension e) + (Dict Text e)) + +(type: #export Extensions + {#analysis (Extension Analysis) + #synthesis (Extension Synthesis) + #translation (Extension Translation) + #statement (Extension Statement)}) + +(def: #export fresh + Extensions + {#analysis (dict.new text.Hash) + #synthesis (dict.new text.Hash) + #translation (dict.new text.Hash) + #statement (dict.new text.Hash)}) + +(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 [ ] + [(def: #export ( name) + (-> Text (Meta )) + (do macro.Monad + [extensions ..get] + (case (dict.get name (get@ extensions)) + (#.Some extension) + (wrap extension) + + #.None + (//.throw 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 [ ] + [(def: #export + + ) + + (def: #export + (Meta ) + (|> ..get + (:: macro.Monad map (get@ ))))] + + [no-syntheses all-syntheses (Extension Synthesis) #synthesis (dict.new text.Hash)] + ) + +(do-template [ ] + [(def: #export ( name extension) + (-> Text (Meta Any)) + (do macro.Monad + [extensions ..get + _ (//.assert name + (not (dict.contains? name (get@ extensions)))) + _ (..set (update@ (dict.put name extension) extensions))] + (wrap [])))] + + [install-analysis Analysis #analysis cannot-define-analysis-more-than-once] + [install-synthesis Synthesis #synthesis cannot-define-synthesis-more-than-once] + [install-translation Translation #translation cannot-define-translation-more-than-once] + [install-statement Statement #statement cannot-define-statement-more-than-once] + ) diff --git a/stdlib/source/lux/lang/extension/analysis.lux b/stdlib/source/lux/lang/extension/analysis.lux new file mode 100644 index 000000000..40fd84679 --- /dev/null +++ b/stdlib/source/lux/lang/extension/analysis.lux @@ -0,0 +1,16 @@ +(.module: + lux + (lux (data [text] + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict])))) + [//] + [/common] + [/host]) + +(def: #export defaults + (//.Extension //.Analysis) + (|> /common.specials + (dict.merge /host.specials) + dict.entries + (list/map (function (_ [name proc]) [name (proc name)])) + (dict.from-list text.Hash))) diff --git a/stdlib/source/lux/lang/extension/analysis/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux new file mode 100644 index 000000000..8c0116721 --- /dev/null +++ b/stdlib/source/lux/lang/extension/analysis/common.lux @@ -0,0 +1,444 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + [thread]) + (concurrency [atom #+ Atom]) + (data [text] + text/format + (coll [list "list/" Functor] + [array] + (dictionary ["dict" unordered #+ Dict]))) + [macro] + (macro [code]) + [lang] + (lang (type ["tc" check]) + [".L" analysis] + (analysis [".A" type] + [".A" case] + [".A" function])) + [io]) + [///]) + +(exception: #export (incorrect-special-arity {name Text} {arity Nat} {args Nat}) + (ex.report ["Special" (%t name)] + ["Expected arity" (|> arity .int %i)] + ["Actual arity" (|> args .int %i)])) + +(exception: #export (invalid-syntax {name Text} {arguments (List Code)}) + (ex.report ["Special" name] + ["Inputs" (|> arguments + list.enumerate + (list/map (function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +## [Utils] +(type: #export Bundle + (Dict Text (-> Text ///.Analysis))) + +(def: #export (install name unnamed) + (-> Text (-> Text ///.Analysis) + (-> Bundle Bundle)) + (dict.put name unnamed)) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash))) + +(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 + [_ (typeA.infer outputT) + argsA (monad.map @ + (function (_ [argT argC]) + (typeA.with-type argT + (analyse argC))) + (list.zip2 inputsT+ args))] + (wrap (#analysisL.Special proc argsA))) + (lang.throw incorrect-special-arity [proc num-expected num-actual])))))) + +(def: #export (nullary valueT proc) + (-> Type Text ///.Analysis) + (simple proc (list) valueT)) + +(def: #export (unary inputT outputT proc) + (-> Type Type Text ///.Analysis) + (simple proc (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT proc) + (-> Type Type Type Text ///.Analysis) + (simple proc (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT proc) + (-> Type Type Type Type Text ///.Analysis) + (simple proc (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: (lux//is proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((binary varT varT Bool proc) + analyse eval args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: (lux//try proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list opC)) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (io.IO varT)) + (analyse opC))] + (wrap (#analysisL.Special proc (list opA)))) + + _ + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (lux//function proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list [_ (#.Symbol ["" func-name])] + [_ (#.Symbol ["" arg-name])] + body)) + (functionA.function analyse func-name arg-name body) + + _ + (lang.throw incorrect-special-arity [proc +3 (list.size args)])))) + +(def: (lux//case proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list input [_ (#.Record branches)])) + (caseA.case analyse input branches) + + _ + (lang.throw incorrect-special-arity [proc +2 (list.size args)])))) + +(def: (lux//in-module proc) + (-> Text ///.Analysis) + (function (_ analyse eval argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (lang.with-current-module module-name + (analyse exprC)) + + _ + (lang.throw invalid-syntax [proc argsC+])))) + +(do-template [ ] + [(def: ( proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list typeC valueC)) + (do macro.Monad + [actualT (eval Type typeC) + _ (typeA.infer (:! Type actualT))] + (typeA.with-type + (analyse valueC))) + + _ + (lang.throw incorrect-special-arity [proc +2 (list.size args)]))))] + + [lux//check (:! Type actualT)] + [lux//coerce Any] + ) + +(def: (lux//check//type proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list valueC)) + (do macro.Monad + [_ (typeA.infer Type) + valueA (typeA.with-type Type + (analyse valueC))] + (wrap valueA)) + + _ + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) + +(def: lux-procs + Bundle + (|> (dict.new text.Hash) + (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 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) + (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) + (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) + (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)))) + ))) + +(def: (array//get proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((binary (type (Array varT)) Nat (type (Maybe varT)) proc) + analyse eval args)))) + +(def: (array//put proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc) + analyse eval args)))) + +(def: (array//remove proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((binary (type (Array varT)) Nat (type (Array varT)) proc) + analyse eval args)))) + +(def: array-procs + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash) + (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 "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] (typeA.with-env tc.var) + _ (typeA.infer (type (Atom varT))) + initA (typeA.with-type varT + (analyse initC))] + (wrap (#analysisL.Special proc (list initA)))) + + _ + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (atom-read proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((unary (type (Atom varT)) varT proc) + analyse eval args)))) + +(def: (atom//compare-and-swap proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((trinary (type (Atom varT)) varT varT Bool proc) + analyse eval args)))) + +(def: atom-procs + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash) + (install "new" atom-new) + (install "read" atom-read) + (install "compare-and-swap" atom//compare-and-swap) + ))) + +(def: (box//new proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list initC)) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (All [!] (thread.Box ! varT)))) + initA (typeA.with-type varT + (analyse initC))] + (wrap (#analysisL.Special proc (list initA)))) + + _ + (lang.throw incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (box//read proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((unary (type (thread.Box threadT varT)) varT proc) + analyse eval args)))) + +(def: (box//write proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (do macro.Monad + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((binary varT (type (thread.Box threadT varT)) Any proc) + analyse eval args)))) + +(def: box-procs + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash) + (install "new" box//new) + (install "read" box//read) + (install "write" box//write) + ))) + +(def: process-procs + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash) + (install "parallelism-level" (nullary Nat)) + (install "schedule" (binary Nat (type (io.IO Any)) Any)) + ))) + +(def: #export specials + Bundle + (<| (prefix "lux") + (|> (dict.new text.Hash) + (dict.merge lux-procs) + (dict.merge bit-procs) + (dict.merge int-procs) + (dict.merge deg-procs) + (dict.merge frac-procs) + (dict.merge text-procs) + (dict.merge array-procs) + (dict.merge math-procs) + (dict.merge atom-procs) + (dict.merge box-procs) + (dict.merge process-procs) + (dict.merge io-procs)))) diff --git a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux new file mode 100644 index 000000000..31b811fac --- /dev/null +++ b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux @@ -0,0 +1,1224 @@ +(.module: + [lux #- char int] + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:]) + (concurrency ["A" atom]) + (data ["e" error] + [maybe] + [product] + [bool "bool/" Eq] + [text "text/" Eq] + (text format + ["l" lexer]) + (coll [list "list/" Fold Functor Monoid] + [array] + (dictionary ["dict" unordered #+ Dict]))) + [macro "macro/" Monad] + (macro [code] + ["s" syntax]) + [lang] + (lang [type] + (type ["tc" check]) + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" inference])) + [host]) + ["/" //common] + [///] + ) + +(host.import #long java/lang/reflect/Type + (getTypeName [] String)) + +(def: jvm-type-name + (-> java/lang/reflect/Type Text) + (java/lang/reflect/Type::getTypeName [])) + +(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) + (jvm-type-name jvm-type)) + +(do-template [] + [(exception: #export ( {type Type}) + (%type type))] + + [non-object] + [non-array] + [non-jvm-type] + ) + +(do-template [] + [(exception: #export ( {name Text}) + name)] + + [non-interface] + [non-throwable] + ) + +(do-template [] + [(exception: #export ( {message Text}) + message)] + + [Unknown-Class] + [Primitives-Cannot-Have-Type-Parameters] + [Primitives-Are-Not-Objects] + [Invalid-Type-For-Array-Element] + + [Unknown-Field] + [Mistaken-Field-Owner] + [Not-Virtual-Field] + [Not-Static-Field] + [Cannot-Set-Final-Field] + + [No-Candidates] + [Too-Many-Candidates] + + [Cannot-Cast] + + [Cannot-Possibly-Be-Instance] + + [Cannot-Convert-To-Class] + [Cannot-Convert-To-Parameter] + [Cannot-Convert-To-Lux-Type] + [Unknown-Type-Var] + [Type-Parameter-Mismatch] + [Cannot-Correspond-Type-With-Class] + ) + +(do-template [ ] + [(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 + [_ (typeA.infer Nat) + [var-id varT] (typeA.with-env tc.var) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC))] + (wrap (#analysisL.Special proc (list arrayA)))) + + _ + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (array//new proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list lengthC)) + (do macro.Monad + [lengthA (typeA.with-type Nat + (analyse lengthC)) + expectedT macro.expected-type + [level elem-class] (: (Meta [Nat Text]) + (loop [analysisT expectedT + level +0] + (case analysisT + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur outputT level) + + #.None + (lang.throw non-array expectedT)) + + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (inc level)) + + (#.Primitive class _) + (wrap [level class]) + + _ + (lang.throw non-array expectedT)))) + _ (if (n/> +0 level) + (wrap []) + (lang.throw non-array expectedT))] + (wrap (#analysisL.Special proc (list (analysisL.nat (dec level)) + (analysisL.text elem-class) + lengthA)))) + + _ + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (check-jvm objectT) + (-> Type (Meta Text)) + (case objectT + (#.Primitive name _) + (macro/wrap name) + + (#.Named name unnamed) + (check-jvm unnamed) + + (#.Var id) + (macro/wrap "java.lang.Object") + + (^template [] + ( env unquantified) + (check-jvm unquantified)) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (check-jvm outputT) + + #.None + (lang.throw non-object objectT)) + + _ + (lang.throw non-object objectT))) + +(def: (check-object objectT) + (-> Type (Meta Text)) + (do macro.Monad + [name (check-jvm objectT)] + (if (dict.contains? name boxes) + (lang.throw Primitives-Are-Not-Objects name) + (macro/wrap name)))) + +(def: (box-array-element-type elemT) + (-> Type (Meta [Type Text])) + (case elemT + (#.Primitive name #.Nil) + (let [boxed-name (|> (dict.get name boxes) + (maybe.default name))] + (macro/wrap [(#.Primitive boxed-name #.Nil) + boxed-name])) + + (#.Primitive name _) + (if (dict.contains? name boxes) + (lang.throw Primitives-Cannot-Have-Type-Parameters name) + (macro/wrap [elemT name])) + + _ + (lang.throw Invalid-Type-For-Array-Element (%type elemT)))) + +(def: (array//read proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC idxC)) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer varT) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (tc.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC))] + (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA arrayA)))) + + _ + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) + +(def: (array//write proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC idxC valueC)) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Array varT))) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (tc.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC)) + valueA (typeA.with-type valueT + (analyse valueC))] + (wrap (#analysisL.Special proc (list (analysisL.text elem-class) idxA valueA arrayA)))) + + _ + (lang.throw /.incorrect-special-arity [proc +3 (list.size args)])))) + +(def: array-procs + /.Bundle + (<| (/.prefix "array") + (|> (dict.new text.Hash) + (/.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 (#analysisL.Special proc (list)))) + + _ + (lang.throw /.incorrect-special-arity [proc +0 (list.size args)])))) + +(def: (object//null? proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list objectC)) + (do macro.Monad + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (check-object objectT)] + (wrap (#analysisL.Special proc (list objectA)))) + + _ + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (object//synchronized proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list monitorC exprC)) + (do macro.Monad + [[monitorT monitorA] (typeA.with-inference + (analyse monitorC)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (#analysisL.Special proc (list monitorA exprA)))) + + _ + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) + +(host.import java/lang/Object + (equals [Object] boolean)) + +(host.import java/lang/ClassLoader) + +(host.import java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) + +(host.import java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/reflect/TypeVariable d) + (getName [] String) + (getBounds [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) + +(host.import java/lang/reflect/Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(host.import java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type)) + +(host.import java/lang/reflect/Method + (getName [] String) + (getModifiers [] int) + (getDeclaringClass [] (Class Object)) + (getTypeParameters [] (Array (TypeVariable Method))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/reflect/Constructor c) + (getModifiers [] int) + (getDeclaringClass [] (Class c)) + (getTypeParameters [] (Array (TypeVariable (Constructor c)))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/Class c) + (getName [] String) + (getModifiers [] int) + (#static forName [String] #try (Class Object)) + (isAssignableFrom [(Class Object)] boolean) + (getTypeParameters [] (Array (TypeVariable (Class c)))) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) + (getDeclaredField [String] #try Field) + (getConstructors [] (Array (Constructor Object))) + (getDeclaredMethods [] (Array Method))) + +(def: (load-class name) + (-> Text (Meta (Class Object))) + (do macro.Monad + [] + (case (Class::forName [name]) + (#e.Success [class]) + (wrap class) + + (#e.Error error) + (lang.throw Unknown-Class name)))) + +(def: (sub-class? super sub) + (-> Text Text (Meta Bool)) + (do macro.Monad + [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 + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference + (analyse exceptionC)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Meta Any) + (if ? + (wrap []) + (lang.throw non-throwable exception-class)))] + (wrap (#analysisL.Special proc (list exceptionA)))) + + _ + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (object//class proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do macro.Monad + [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + _ (load-class class)] + (wrap (#analysisL.Special proc (list (analysisL.text class))))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-special-arity [proc +1 (list.size args)])))) + +(def: (object//instance? proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC objectC)) + (case classC + [_ (#.Text class)] + (do macro.Monad + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (wrap (#analysisL.Special proc (list (analysisL.text class)))) + (lang.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) + +(def: (java-type-to-class type) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) + + ## else + (lang.throw Cannot-Convert-To-Class (jvm-type-name type)))) + +(type: Mappings + (Dict Text Type)) + +(def: fresh-mappings Mappings (dict.new text.Hash)) + +(def: (java-type-to-lux-type mappings java-type) + (-> Mappings java/lang/reflect/Type (Meta Type)) + (cond (host.instance? TypeVariable java-type) + (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] + (case (dict.get var-name mappings) + (#.Some var-type) + (macro/wrap var-type) + + #.None + (lang.throw Unknown-Type-Var var-name))) + + (host.instance? WildcardType java-type) + (let [java-type (:! WildcardType java-type)] + (case [(array.read +0 (WildcardType::getUpperBounds [] java-type)) + (array.read +0 (WildcardType::getLowerBounds [] java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) + (java-type-to-lux-type mappings bound) + + _ + (macro/wrap Any))) + + (host.instance? Class java-type) + (let [java-type (:! (Class Object) java-type) + class-name (Class::getName [] java-type)] + (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) + +0 + (#.Primitive class-name (list)) + + arity + (|> (list.n/range +0 (dec arity)) + list.reverse + (list/map (|>> (n/* +2) inc #.Bound)) + (#.Primitive class-name) + (type.univ-q arity))))) + + (host.instance? ParameterizedType java-type) + (let [java-type (:! ParameterizedType java-type) + raw (ParameterizedType::getRawType [] java-type)] + (if (host.instance? Class raw) + (do macro.Monad + [paramsT (|> java-type + (ParameterizedType::getActualTypeArguments []) + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) + paramsT))) + (lang.throw jvm-type-is-not-a-class raw))) + + (host.instance? GenericArrayType java-type) + (do macro.Monad + [innerT (|> (:! GenericArrayType java-type) + (GenericArrayType::getGenericComponentType []) + (java-type-to-lux-type mappings))] + (wrap (#.Primitive "#Array" (list innerT)))) + + ## else + (lang.throw Cannot-Convert-To-Lux-Type (jvm-type-name java-type)))) + +(def: (correspond-type-params class type) + (-> (Class Object) Type (Meta Mappings)) + (case type + (#.Primitive name params) + (let [class-name (Class::getName [] class) + class-params (array.to-list (Class::getTypeParameters [] class)) + num-class-params (list.size class-params) + num-type-params (list.size params)] + (cond (not (text/= class-name name)) + (lang.throw Cannot-Correspond-Type-With-Class + (format "Class = " class-name "\n" + "Type = " (%type type))) + + (not (n/= num-class-params num-type-params)) + (lang.throw Type-Parameter-Mismatch + (format "Expected: " (%i (.int num-class-params)) "\n" + " Actual: " (%i (.int num-type-params)) "\n" + " Class: " class-name "\n" + " Type: " (%type type))) + + ## else + (macro/wrap (|> params + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dict.from-list text.Hash))) + )) + + _ + (lang.throw non-jvm-type type))) + +(def: (object//cast proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list valueC)) + (do macro.Monad + [toT macro.expected-type + to-name (check-jvm toT) + [valueT valueA] (typeA.with-inference + (analyse valueC)) + from-name (check-jvm valueT) + can-cast? (: (Meta Bool) + (case [from-name to-name] + (^template [ ] + (^or [ ] + [ ]) + (do @ + [_ (typeA.infer (#.Primitive to-name (list)))] + (wrap true))) + (["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + + _ + (do @ + [_ (lang.assert Primitives-Are-Not-Objects from-name + (not (dict.contains? from-name boxes))) + _ (lang.assert Primitives-Are-Not-Objects to-name + (not (dict.contains? to-name boxes))) + to-class (load-class to-name)] + (loop [[current-name currentT] [from-name valueT]] + (if (text/= to-name current-name) + (do @ + [_ (typeA.infer toT)] + (wrap true)) + (do @ + [current-class (load-class current-name) + _ (lang.assert Cannot-Cast (format "From class/primitive: " current-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n") + (Class::isAssignableFrom [current-class] to-class)) + candiate-parents (monad.map @ + (function (_ java-type) + (do @ + [class-name (java-type-to-class java-type) + class (load-class class-name)] + (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)]))) + (list& (Class::getGenericSuperclass [] current-class) + (array.to-list (Class::getGenericInterfaces [] current-class))))] + (case (|> candiate-parents + (list.filter product.right) + (list/map product.left)) + (#.Cons [next-name nextJT] _) + (do @ + [mapping (correspond-type-params current-class currentT) + nextT (java-type-to-lux-type mapping nextJT)] + (recur [next-name nextT])) + + #.Nil + (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n"))) + ))))))] + (if can-cast? + (wrap (#analysisL.Special proc (list (analysisL.text from-name) + (analysisL.text to-name) + valueA))) + (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n")))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: object-procs + /.Bundle + (<| (/.prefix "object") + (|> (dict.new text.Hash) + (/.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 + [class (load-class class-name)] + (case (Class::getDeclaredField [field-name] class) + (#e.Success field) + (let [owner (Field::getDeclaringClass [] field)] + (if (is? owner class) + (wrap [class field]) + (lang.throw Mistaken-Field-Owner + (format " Field: " field-name "\n" + " Owner Class: " (Class::getName [] owner) "\n" + "Target Class: " class-name "\n")))) + + (#e.Error _) + (lang.throw Unknown-Field (format class-name "#" field-name))))) + +(def: (static-field class-name field-name) + (-> Text Text (Meta [Type Bool])) + (do macro.Monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (Modifier::isStatic [modifiers]) + (let [fieldJT (Field::getGenericType [] fieldJ)] + (do @ + [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal [modifiers])]))) + (lang.throw Not-Static-Field (format class-name "#" field-name))))) + +(def: (virtual-field class-name field-name objectT) + (-> Text Text Type (Meta [Type Bool])) + (do macro.Monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (not (Modifier::isStatic [modifiers])) + (do @ + [#let [fieldJT (Field::getGenericType [] fieldJ) + var-names (|> class + (Class::getTypeParameters []) + array.to-list + (list/map (TypeVariable::getName [])))] + mappings (: (Meta Mappings) + (case objectT + (#.Primitive _class-name _class-params) + (do @ + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (lang.assert Type-Parameter-Mismatch + (format "Expected: " (%i (.int num-params)) "\n" + " Actual: " (%i (.int num-vars)) "\n" + " Class: " _class-name "\n" + " Type: " (%type objectT)) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dict.from-list text.Hash)))) + + _ + (lang.throw non-object objectT))) + fieldT (java-type-to-lux-type mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal [modifiers])])) + (lang.throw Not-Virtual-Field (format class-name "#" field-name))))) + +(def: (static//get proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [[fieldT final?] (static-field class field)] + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field))))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-special-arity [proc +2 (list.size args)])))) + +(def: (static//put proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [_ (typeA.infer Any) + [fieldT final?] (static-field class field) + _ (lang.assert Cannot-Set-Final-Field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-special-arity [proc +3 (list.size args)])))) + +(def: (virtual//get proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [fieldT final?] (virtual-field class field objectT)] + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) objectA)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-special-arity [proc +3 (list.size args)])))) + +(def: (virtual//put proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC valueC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [fieldT final?] (virtual-field class field objectT) + _ (lang.assert Cannot-Set-Final-Field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysisL.Special proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-special-arity [proc +4 (list.size args)])))) + +(def: (java-type-to-parameter type) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type))) + + (or (host.instance? TypeVariable type) + (host.instance? WildcardType type)) + (macro/wrap "java.lang.Object") + + (host.instance? GenericArrayType type) + (do macro.Monad + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))] + (wrap (format componentP "[]"))) + + ## else + (lang.throw Cannot-Convert-To-Parameter (jvm-type-name type)))) + +(type: Method-Type + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-type arg-classes method) + (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) + (do macro.Monad + [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) inc #.Bound)) + +(def: (type-vars amount offset) + (-> Nat Nat (List Type)) + (if (n/= +0 amount) + (list) + (|> (list.n/range offset (|> amount dec (n/+ offset))) + (list/map idx-to-bound)))) + +(def: (method-to-type method-type method) + (-> Method-Type Method (Meta [Type (List Type)])) + (let [owner (Method::getDeclaringClass [] method) + owner-name (Class::getName [] owner) + owner-tvars (case method-type + #Static + (list) + + _ + (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName [])))) + method-tvars (|> (Method::getTypeParameters [] method) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) + num-method-tvars (list.size method-tvars) + all-tvars (list/compose owner-tvars method-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars +0) + method-tvarsT (type-vars num-method-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT method-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash))))] + (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 + (lang.throw No-Candidates (format class-name "#" method-name)) + + (#.Cons candidate #.Nil) + (|> candidate product.right (method-to-type method-type)) + + _ + (lang.throw Too-Many-Candidates (format class-name "#" method-name))))) + +(def: (constructor-to-type constructor) + (-> (Constructor Object) (Meta [Type (List Type)])) + (let [owner (Constructor::getDeclaringClass [] constructor) + owner-name (Class::getName [] owner) + owner-tvars (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName []))) + constructor-tvars (|> (Constructor::getTypeParameters [] constructor) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) + all-tvars (list/compose owner-tvars constructor-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars +0) + constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT constructor-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash))))] + (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 + (lang.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) + + (#.Cons candidate #.Nil) + (|> candidate product.right constructor-to-type) + + _ + (lang.throw Too-Many-Candidates class-name)))) + +(def: (decorate-inputs typesT inputsA) + (-> (List Text) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip2 (list/map analysisL.text typesT)) + (list/map (function (_ [type value]) + (analysisL.product-analysis (list type value)))))) + +(def: (invoke//static proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (methods class method #Static argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//virtual proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method objectC argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (methods class method #Virtual argsT) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + outputJC (check-jvm outputT)] + (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//special proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]]) + (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) + (#e.Success [_ [class method objectC argsTC _]]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (methods class method #Special argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Special proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//interface proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class-name method objectC argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + class (load-class class-name) + _ (lang.assert non-interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) + [methodT exceptionsT] (methods class-name method #Interface argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Special proc + (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) + (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//constructor proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text (List [Text Code])]) + (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (constructor-methods class argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] + (wrap (#analysisL.Special proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: member-procs + /.Bundle + (<| (/.prefix "member") + (|> (dict.new text.Hash) + (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 specials + /.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/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux index 80e6d4740..8d4fdf981 100644 --- a/stdlib/source/lux/lang/init.lux +++ b/stdlib/source/lux/lang/init.lux @@ -1,11 +1,11 @@ (.module: lux - ## (// [".L" extension] - ## (extension [".E" analysis] - ## [".E" synthesis] - ## [".E" translation] - ## [".E" statement])) - ) + (// [".L" extension] + (extension [".E" analysis] + ## [".E" synthesis] + ## [".E" translation] + ## [".E" statement] + ))) (def: #export (cursor file) (-> Text Cursor) @@ -30,7 +30,13 @@ (def: #export info Info {#.target (for {"JVM" "JVM" - "JS" "JS"}) + "JS" "JS" + "Lua" "Lua" + "Python" "Python" + "Ruby" "Ruby" + "PHP" "PHP" + "Scheme" "Scheme" + "Common Lisp" "Common Lisp"}) #.version ..version #.mode #.Build}) @@ -47,10 +53,9 @@ #.seed +0 #.scope-type-vars (list) #.extensions (:! Nothing - [] - ## {#extensionL.analysis analysisE.defaults - ## #extensionL.synthesis synthesisE.defaults - ## #extensionL.translation translationE.defaults - ## #extensionL.statement statementE.defaults} - ) + {#extensionL.analysis analysisE.defaults + #extensionL.synthesis (:!! []) ## synthesisE.defaults + #extensionL.translation (:!! []) ## translationE.defaults + #extensionL.statement (:!! []) ## statementE.defaults + }) #.host (:! Nothing host)}) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux new file mode 100644 index 000000000..33c8aa063 --- /dev/null +++ b/stdlib/source/lux/lang/synthesis.lux @@ -0,0 +1,8 @@ +(.module: + lux) + +(def: #export Arity Nat) + +(type: #export Synthesis Code) + +(type: #export Path Code) diff --git a/stdlib/test/test/lux/lang/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/analysis/procedure/common.lux new file mode 100644 index 000000000..898376045 --- /dev/null +++ b/stdlib/test/test/lux/lang/analysis/procedure/common.lux @@ -0,0 +1,316 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data text/format + ["e" error] + [product] + (coll [array])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type "type/" Eq] + [".L" scope] + [".L" init] + (analysis [".A" type])) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(context: "Lux procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.primitive + [antiT antiC] (|> _primitive.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 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.unicode +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.unicode +5) (:: @ map code.text)) + paramC (|> (r.unicode +5) (:: @ map code.text)) + replacementC (|> (r.unicode +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] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +5) + #let [arrayT (type (Array elemT)) + g!array (code.local-symbol var-name) + array-operation (function (_ output-type code) + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name arrayT] + (typeA.with-type output-type + (_primitive.analyse code)))) + (macro.run (initL.compiler [])) + (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))] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (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"])) + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC paramC) Frac))] + + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"]))))))) + +(context: "Atom procedures" + (<| (times +100) + (do @ + [[elemT elemC] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +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." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type elemT + (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + (test "Can swap the value of an atomic reference." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type Bool + (_primitive.analyse (` ("lux atom compare-and-swap" + (~ (code.symbol ["" var-name])) + (~ elemC) + (~ elemC))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + )))) + +(context: "Process procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.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.unicode +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/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux new file mode 100644 index 000000000..0a60149d5 --- /dev/null +++ b/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux @@ -0,0 +1,541 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data ["e" error] + [product] + [maybe] + [text "text/" Eq] + text/format + (coll [array] + [list "list/" Fold] + (dictionary ["dict" unordered]))) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type] + [".L" init] + (analysis [".A" type]) + (extension (analysis [".AE" host]))) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success true false] + [failure false true] + ) + +(do-template [ ] + [(def: ( syntax output-type) + (-> Code Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse syntax)))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success' true false] + [failure' false true] + ) + +(context: "Conversions [double + float]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] + ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] + ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] + ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] + ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] + ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] + )] + ($_ seq + + ))) + +(context: "Conversions [int]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] + ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] + ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] + ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] + ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] + ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] + )] + ($_ seq + + ))) + +(context: "Conversions [long]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] + ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] + ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] + ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] + ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] + )] + ($_ seq + + ))) + +(context: "Conversions [char + byte + short]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] + ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] + ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] + ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] + ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] + ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] + )] + ($_ seq + + ))) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + ))) + + (context: (format "Bitwise " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " and") ] + [(format "jvm " " or") ] + [(format "jvm " " xor") ] + [(format "jvm " " shl") "java.lang.Integer" ] + [(format "jvm " " shr") "java.lang.Integer" ] + [(format "jvm " " ushr") "java.lang.Integer" ] + )] + ($_ seq + + )))] + + + ["int" "java.lang.Integer" hostAE.Integer] + ["long" "java.lang.Long" hostAE.Long] + ) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["float" "java.lang.Float" hostAE.Float] + ["double" "java.lang.Double" hostAE.Double] + ) + +(do-template [ ] + [(context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["char" "java.lang.Character" hostAE.Character] + ) + +(def: array-type + (r.Random [Text Text]) + (let [entries (dict.entries hostAE.boxes) + num-entries (list.size entries)] + (do r.Monad + [choice (|> r.nat (:: @ map (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/% (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))))) + ))) -- cgit v1.2.3