diff options
Diffstat (limited to 'stdlib/source/lux/language/compiler/extension')
6 files changed, 1710 insertions, 0 deletions
diff --git a/stdlib/source/lux/language/compiler/extension/analysis.lux b/stdlib/source/lux/language/compiler/extension/analysis.lux new file mode 100644 index 000000000..9f48c79b4 --- /dev/null +++ b/stdlib/source/lux/language/compiler/extension/analysis.lux @@ -0,0 +1,18 @@ +(.module: + lux + (lux (data [text] + (collection [list "list/" Functor<List>] + ["dict" dictionary #+ Dictionary]))) + [///analysis #+ Analysis State] + [///synthesis #+ Synthesis] + [//] + [/common] + [/host]) + +(def: #export defaults + (//.Bundle State Analysis Synthesis) + (|> /common.extensions + (dict.merge /host.extensions) + dict.entries + (list/map (function (_ [name proc]) [name (proc name)])) + (dict.from-list text.Hash<Text>))) diff --git a/stdlib/source/lux/language/compiler/extension/analysis/common.lux b/stdlib/source/lux/language/compiler/extension/analysis/common.lux new file mode 100644 index 000000000..a0525cf12 --- /dev/null +++ b/stdlib/source/lux/language/compiler/extension/analysis/common.lux @@ -0,0 +1,375 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + [thread #+ Box]) + (concurrency [atom #+ Atom]) + (data [text] + text/format + (collection [list "list/" Functor<List>] + [array] + ["dict" dictionary #+ Dictionary])) + [language] + (language (type ["tc" check])) + [io #+ IO]) + [////] + (//// [analysis #+ Analysis] + (analysis [".A" type] + [".A" case] + [".A" function])) + [///] + [///bundle]) + +(type: Handler + (///.Handler .Lux .Code Analysis)) + +## [Utils] +(def: (simple extension inputsT+ outputT) + (-> Text (List Type) Type ..Handler) + (let [num-expected (list.size inputsT+)] + (function (_ analyse args) + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do ////.Monad<Operation> + [_ (typeA.infer outputT) + argsA (monad.map @ + (function (_ [argT argC]) + (typeA.with-type argT + (analyse argC))) + (list.zip2 inputsT+ args))] + (wrap (#///.Extension extension argsA))) + (language.throw ///bundle.incorrect-arity [extension num-expected num-actual])))))) + +(def: #export (nullary valueT extension) + (-> Type Text ..Handler) + (simple extension (list) valueT)) + +(def: #export (unary inputT outputT extension) + (-> Type Type Text ..Handler) + (simple extension (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT extension) + (-> Type Type Type Text ..Handler) + (simple extension (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT extension) + (-> Type Type Type Type Text ..Handler) + (simple extension (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: (lux//is extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var)] + ((binary varT varT Bool extension) + analyse args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: (lux//try extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list opC)) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (IO varT)) + (analyse opC))] + (wrap (#///.Extension extension (list opA)))) + + _ + (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (lux//in-module extension) + (-> Text ..Handler) + (function (_ analyse argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (language.with-current-module module-name + (analyse exprC)) + + _ + (language.throw ///bundle.invalid-syntax [extension])))) + +## (do-template [<name> <type>] +## [(def: (<name> extension) +## (-> Text ..Handler) +## (function (_ analyse args) +## (case args +## (^ (list typeC valueC)) +## (do ////.Monad<Operation> +## [actualT (eval Type typeC) +## _ (typeA.infer (:coerce Type actualT))] +## (typeA.with-type <type> +## (analyse valueC))) + +## _ +## (language.throw ///bundle.incorrect-arity [extension +2 (list.size args)]))))] + +## [lux//check (:coerce Type actualT)] +## [lux//coerce Any] +## ) + +(def: (lux//check//type extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list valueC)) + (do ////.Monad<Operation> + [_ (typeA.infer Type) + valueA (typeA.with-type Type + (analyse valueC))] + (wrap valueA)) + + _ + (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: bundle/lux + ///.Bundle + (|> ///.fresh + (///bundle.install "is" lux//is) + (///bundle.install "try" lux//try) + (///bundle.install "check" lux//check) + (///bundle.install "coerce" lux//coerce) + (///bundle.install "check type" lux//check//type) + (///bundle.install "in-module" lux//in-module))) + +(def: bundle/io + ///.Bundle + (<| (///bundle.prefix "io") + (|> ///.fresh + (///bundle.install "log" (unary Text Any)) + (///bundle.install "error" (unary Text Nothing)) + (///bundle.install "exit" (unary Int Nothing)) + (///bundle.install "current-time" (nullary Int))))) + +(def: bundle/bit + ///.Bundle + (<| (///bundle.prefix "bit") + (|> ///.fresh + (///bundle.install "and" (binary Nat Nat Nat)) + (///bundle.install "or" (binary Nat Nat Nat)) + (///bundle.install "xor" (binary Nat Nat Nat)) + (///bundle.install "left-shift" (binary Nat Nat Nat)) + (///bundle.install "logical-right-shift" (binary Nat Nat Nat)) + (///bundle.install "arithmetic-right-shift" (binary Int Nat Int)) + ))) + +(def: bundle/int + ///.Bundle + (<| (///bundle.prefix "int") + (|> ///.fresh + (///bundle.install "+" (binary Int Int Int)) + (///bundle.install "-" (binary Int Int Int)) + (///bundle.install "*" (binary Int Int Int)) + (///bundle.install "/" (binary Int Int Int)) + (///bundle.install "%" (binary Int Int Int)) + (///bundle.install "=" (binary Int Int Bool)) + (///bundle.install "<" (binary Int Int Bool)) + (///bundle.install "min" (nullary Int)) + (///bundle.install "max" (nullary Int)) + (///bundle.install "to-nat" (unary Int Nat)) + (///bundle.install "to-frac" (unary Int Frac)) + (///bundle.install "char" (unary Int Text))))) + +(def: bundle/frac + ///.Bundle + (<| (///bundle.prefix "frac") + (|> ///.fresh + (///bundle.install "+" (binary Frac Frac Frac)) + (///bundle.install "-" (binary Frac Frac Frac)) + (///bundle.install "*" (binary Frac Frac Frac)) + (///bundle.install "/" (binary Frac Frac Frac)) + (///bundle.install "%" (binary Frac Frac Frac)) + (///bundle.install "=" (binary Frac Frac Bool)) + (///bundle.install "<" (binary Frac Frac Bool)) + (///bundle.install "smallest" (nullary Frac)) + (///bundle.install "min" (nullary Frac)) + (///bundle.install "max" (nullary Frac)) + (///bundle.install "to-rev" (unary Frac Rev)) + (///bundle.install "to-int" (unary Frac Int)) + (///bundle.install "encode" (unary Frac Text)) + (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle/text + ///.Bundle + (<| (///bundle.prefix "text") + (|> ///.fresh + (///bundle.install "=" (binary Text Text Bool)) + (///bundle.install "<" (binary Text Text Bool)) + (///bundle.install "concat" (binary Text Text Text)) + (///bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (///bundle.install "size" (unary Text Nat)) + (///bundle.install "hash" (unary Text Nat)) + (///bundle.install "replace-once" (trinary Text Text Text Text)) + (///bundle.install "replace-all" (trinary Text Text Text Text)) + (///bundle.install "char" (binary Text Nat (type (Maybe Nat)))) + (///bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) + ))) + +(def: (array//get extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var)] + ((binary (type (Array varT)) Nat (type (Maybe varT)) extension) + analyse args)))) + +(def: (array//put extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var)] + ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension) + analyse args)))) + +(def: (array//remove extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var)] + ((binary (type (Array varT)) Nat (type (Array varT)) extension) + analyse args)))) + +(def: bundle/array + ///.Bundle + (<| (///bundle.prefix "array") + (|> ///.fresh + (///bundle.install "new" (unary Nat Array)) + (///bundle.install "get" array//get) + (///bundle.install "put" array//put) + (///bundle.install "remove" array//remove) + (///bundle.install "size" (unary (type (Ex [a] (Array a))) Nat)) + ))) + +(def: bundle/math + ///.Bundle + (<| (///bundle.prefix "math") + (|> ///.fresh + (///bundle.install "cos" (unary Frac Frac)) + (///bundle.install "sin" (unary Frac Frac)) + (///bundle.install "tan" (unary Frac Frac)) + (///bundle.install "acos" (unary Frac Frac)) + (///bundle.install "asin" (unary Frac Frac)) + (///bundle.install "atan" (unary Frac Frac)) + (///bundle.install "cosh" (unary Frac Frac)) + (///bundle.install "sinh" (unary Frac Frac)) + (///bundle.install "tanh" (unary Frac Frac)) + (///bundle.install "exp" (unary Frac Frac)) + (///bundle.install "log" (unary Frac Frac)) + (///bundle.install "ceil" (unary Frac Frac)) + (///bundle.install "floor" (unary Frac Frac)) + (///bundle.install "round" (unary Frac Frac)) + (///bundle.install "atan2" (binary Frac Frac Frac)) + (///bundle.install "pow" (binary Frac Frac Frac)) + ))) + +(def: (atom-new extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list initC)) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Atom varT))) + initA (typeA.with-type varT + (analyse initC))] + (wrap (#///.Extension extension (list initA)))) + + _ + (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (atom-read extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var)] + ((unary (type (Atom varT)) varT extension) + analyse args)))) + +(def: (atom//compare-and-swap extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var)] + ((trinary (type (Atom varT)) varT varT Bool extension) + analyse args)))) + +(def: bundle/atom + ///.Bundle + (<| (///bundle.prefix "atom") + (|> ///.fresh + (///bundle.install "new" atom-new) + (///bundle.install "read" atom-read) + (///bundle.install "compare-and-swap" atom//compare-and-swap) + ))) + +(def: (box//new extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list initC)) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (All [!] (Box ! varT)))) + initA (typeA.with-type varT + (analyse initC))] + (wrap (#///.Extension extension (list initA)))) + + _ + (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (box//read extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((unary (type (Box threadT varT)) varT extension) + analyse args)))) + +(def: (box//write extension) + (-> Text ..Handler) + (function (_ analyse args) + (do ////.Monad<Operation> + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((binary varT (type (Box threadT varT)) Any extension) + analyse args)))) + +(def: bundle/box + ///.Bundle + (<| (///bundle.prefix "box") + (|> ///.fresh + (///bundle.install "new" box//new) + (///bundle.install "read" box//read) + (///bundle.install "write" box//write) + ))) + +(def: bundle/process + ///.Bundle + (<| (///bundle.prefix "process") + (|> ///.fresh + (///bundle.install "parallelism" (nullary Nat)) + (///bundle.install "schedule" (binary Nat (type (IO Any)) Any)) + ))) + +(def: #export bundle + ///.Bundle + (<| (///bundle.prefix "lux") + (|> ///.fresh + (dict.merge bundle/lux) + (dict.merge bundle/bit) + (dict.merge bundle/int) + (dict.merge bundle/frac) + (dict.merge bundle/text) + (dict.merge bundle/array) + (dict.merge bundle/math) + (dict.merge bundle/atom) + (dict.merge bundle/box) + (dict.merge bundle/process) + (dict.merge bundle/io)) + )) diff --git a/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux new file mode 100644 index 000000000..c11a6d5f4 --- /dev/null +++ b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux @@ -0,0 +1,1268 @@ +(.module: + [lux #- char int] + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:]) + (data ["e" error] + [maybe] + [product] + [bool "bool/" Equivalence<Bool>] + [text "text/" Equivalence<Text>] + (text format + ["l" lexer]) + (collection [list "list/" Fold<List> Functor<List> Monoid<List>] + [array] + ["dict" dictionary #+ Dictionary])) + [macro "macro/" Monad<Meta>] + (macro [code] + ["s" syntax]) + [language] + (language [type] + (type ["tc" check])) + [host]) + ["/" //common] + (//// [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" inference])) + [///] + ) + +(host.import: #long java/lang/reflect/Type + (getTypeName [] String)) + +(def: jvm-type-name + (-> java/lang/reflect/Type Text) + (java/lang/reflect/Type::getTypeName [])) + +(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) + (jvm-type-name jvm-type)) + +(do-template [<name>] + [(exception: #export (<name> {type Type}) + (%type type))] + + [non-object] + [non-array] + [non-jvm-type] + ) + +(do-template [<name>] + [(exception: #export (<name> {name Text}) + name)] + + [non-interface] + [non-throwable] + ) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [unknown-class] + [primitives-cannot-have-type-parameters] + [primitives-are-not-objects] + [invalid-type-for-array-element] + + [unknown-field] + [mistaken-field-owner] + [not-a-virtual-field] + [not-a-static-field] + [cannot-set-a-final-field] + + [cannot-cast] + + [cannot-possibly-be-an-instance] + + [cannot-convert-to-a-class] + [cannot-convert-to-a-parameter] + [cannot-convert-to-a-lux-type] + [unknown-type-var] + [type-parameter-mismatch] + [cannot-correspond-type-with-a-class] + ) + +(do-template [<name>] + [(exception: #export (<name> {class Text} {method Text} {hints (List [Type (List Type)])}) + (ex.report ["Class" class] + ["Method" method] + ["Hints" (|> hints + (list/map (|>> %type (format "\n\t"))) + (text.join-with ""))]))] + + [no-candidates] + [too-many-candidates] + ) + +(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 + (Dictionary Text Text) + (|> (list ["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + (dict.from-list text.Hash<Text>))) + +(def: (array//length proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC)) + (do macro.Monad<Meta> + [_ (typeA.infer Nat) + [var-id varT] (typeA.with-env tc.var) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC))] + (wrap (#analysisL.Extension proc (list arrayA)))) + + _ + (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (array//new proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list lengthC)) + (do macro.Monad<Meta> + [lengthA (typeA.with-type Nat + (analyse lengthC)) + expectedT macro.expected-type + [level elem-class] (: (Meta [Nat Text]) + (loop [analysisT expectedT + level +0] + (case analysisT + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur outputT level) + + #.None + (language.throw non-array expectedT)) + + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (inc level)) + + (#.Primitive class _) + (wrap [level class]) + + _ + (language.throw non-array expectedT)))) + _ (if (n/> +0 level) + (wrap []) + (language.throw non-array expectedT))] + (wrap (#analysisL.Extension proc (list (analysisL.nat (dec level)) + (analysisL.text elem-class) + lengthA)))) + + _ + (language.throw /.incorrect-extension-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 + (language.throw non-object objectT)) + + _ + (language.throw non-object objectT))) + +(def: (check-object objectT) + (-> Type (Meta Text)) + (do macro.Monad<Meta> + [name (check-jvm objectT)] + (if (dict.contains? name boxes) + (language.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) + (language.throw primitives-cannot-have-type-parameters name) + (macro/wrap [elemT name])) + + _ + (language.throw invalid-type-for-array-element (%type elemT)))) + +(def: (array//read proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC idxC)) + (do macro.Monad<Meta> + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer varT) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (tc.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC))] + (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA arrayA)))) + + _ + (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + +(def: (array//write proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC idxC valueC)) + (do macro.Monad<Meta> + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Array varT))) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (tc.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC)) + valueA (typeA.with-type valueT + (analyse valueC))] + (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA valueA arrayA)))) + + _ + (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + +(def: array-procs + /.Bundle + (<| (/.prefix "array") + (|> (dict.new text.Hash<Text>) + (/.install "length" array//length) + (/.install "new" array//new) + (/.install "read" array//read) + (/.install "write" array//write) + ))) + +(def: (object//null proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list)) + (do macro.Monad<Meta> + [expectedT macro.expected-type + _ (check-object expectedT)] + (wrap (#analysisL.Extension proc (list)))) + + _ + (language.throw /.incorrect-extension-arity [proc +0 (list.size args)])))) + +(def: (object//null? proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list objectC)) + (do macro.Monad<Meta> + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (check-object objectT)] + (wrap (#analysisL.Extension proc (list objectA)))) + + _ + (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (object//synchronized proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list monitorC exprC)) + (do macro.Monad<Meta> + [[monitorT monitorA] (typeA.with-inference + (analyse monitorC)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (#analysisL.Extension proc (list monitorA exprA)))) + + _ + (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + +(host.import: java/lang/Object + (equals [Object] boolean)) + +(host.import: java/lang/ClassLoader) + +(host.import: java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) + +(host.import: java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) + +(host.import: (java/lang/reflect/TypeVariable d) + (getName [] String) + (getBounds [] (Array java/lang/reflect/Type))) + +(host.import: (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) + +(host.import: java/lang/reflect/Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(host.import: java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type)) + +(host.import: java/lang/reflect/Method + (getName [] String) + (getModifiers [] int) + (getDeclaringClass [] (Class Object)) + (getTypeParameters [] (Array (TypeVariable Method))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(host.import: (java/lang/reflect/Constructor c) + (getModifiers [] int) + (getDeclaringClass [] (Class c)) + (getTypeParameters [] (Array (TypeVariable (Constructor c)))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(host.import: (java/lang/Class c) + (getName [] String) + (getModifiers [] int) + (#static forName [String] #try (Class Object)) + (isAssignableFrom [(Class Object)] boolean) + (getTypeParameters [] (Array (TypeVariable (Class c)))) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) + (getDeclaredField [String] #try Field) + (getConstructors [] (Array (Constructor Object))) + (getDeclaredMethods [] (Array Method))) + +(def: (load-class name) + (-> Text (Meta (Class Object))) + (do macro.Monad<Meta> + [] + (case (Class::forName [name]) + (#e.Success [class]) + (wrap class) + + (#e.Error error) + (language.throw unknown-class name)))) + +(def: (sub-class? super sub) + (-> Text Text (Meta Bool)) + (do macro.Monad<Meta> + [super (load-class super) + sub (load-class sub)] + (wrap (Class::isAssignableFrom [sub] super)))) + +(def: (object//throw proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list exceptionC)) + (do macro.Monad<Meta> + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference + (analyse exceptionC)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Meta Any) + (if ? + (wrap []) + (language.throw non-throwable exception-class)))] + (wrap (#analysisL.Extension proc (list exceptionA)))) + + _ + (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (object//class proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do macro.Monad<Meta> + [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + _ (load-class class)] + (wrap (#analysisL.Extension proc (list (analysisL.text class))))) + + _ + (language.throw /.invalid-syntax [proc args])) + + _ + (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (object//instance? proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC objectC)) + (case classC + [_ (#.Text class)] + (do macro.Monad<Meta> + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (wrap (#analysisL.Extension proc (list (analysisL.text class)))) + (language.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) + + _ + (language.throw /.invalid-syntax [proc args])) + + _ + (language.throw /.incorrect-extension-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 [] (:coerce Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType type))) + + ## else + (language.throw cannot-convert-to-a-class (jvm-type-name type)))) + +(type: Mappings + (Dictionary 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 [] (:coerce TypeVariable java-type))] + (case (dict.get var-name mappings) + (#.Some var-type) + (macro/wrap var-type) + + #.None + (language.throw unknown-type-var var-name))) + + (host.instance? WildcardType java-type) + (let [java-type (:coerce 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 (:coerce (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 #.Parameter)) + (#.Primitive class-name) + (type.univ-q arity))))) + + (host.instance? ParameterizedType java-type) + (let [java-type (:coerce 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 [] (:coerce (Class Object) raw)) + paramsT))) + (language.throw jvm-type-is-not-a-class raw))) + + (host.instance? GenericArrayType java-type) + (do macro.Monad<Meta> + [innerT (|> (:coerce GenericArrayType java-type) + (GenericArrayType::getGenericComponentType []) + (java-type-to-lux-type mappings))] + (wrap (#.Primitive "#Array" (list innerT)))) + + ## else + (language.throw cannot-convert-to-a-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)) + (language.throw cannot-correspond-type-with-a-class + (format "Class = " class-name "\n" + "Type = " (%type type))) + + (not (n/= num-class-params num-type-params)) + (language.throw type-parameter-mismatch + (format "Expected: " (%i (.int num-class-params)) "\n" + " Actual: " (%i (.int num-type-params)) "\n" + " Class: " class-name "\n" + " Type: " (%type type))) + + ## else + (macro/wrap (|> params + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dict.from-list text.Hash<Text>))) + )) + + _ + (language.throw non-jvm-type type))) + +(def: (object//cast proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list valueC)) + (do macro.Monad<Meta> + [toT macro.expected-type + to-name (check-jvm toT) + [valueT valueA] (typeA.with-inference + (analyse valueC)) + from-name (check-jvm valueT) + can-cast? (: (Meta Bool) + (case [from-name to-name] + (^template [<primitive> <object>] + (^or [<primitive> <object>] + [<object> <primitive>]) + (do @ + [_ (typeA.infer (#.Primitive to-name (list)))] + (wrap true))) + (["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + + _ + (do @ + [_ (language.assert primitives-are-not-objects from-name + (not (dict.contains? from-name boxes))) + _ (language.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) + _ (language.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 + (language.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.Extension proc (list (analysisL.text from-name) + (analysisL.text to-name) + valueA))) + (language.throw cannot-cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n")))) + + _ + (language.throw /.invalid-syntax [proc args])))) + +(def: object-procs + /.Bundle + (<| (/.prefix "object") + (|> (dict.new text.Hash<Text>) + (/.install "null" object//null) + (/.install "null?" object//null?) + (/.install "synchronized" object//synchronized) + (/.install "throw" object//throw) + (/.install "class" object//class) + (/.install "instance?" object//instance?) + (/.install "cast" object//cast) + ))) + +(def: (find-field class-name field-name) + (-> Text Text (Meta [(Class Object) Field])) + (do macro.Monad<Meta> + [class (load-class class-name)] + (case (Class::getDeclaredField [field-name] class) + (#e.Success field) + (let [owner (Field::getDeclaringClass [] field)] + (if (is? owner class) + (wrap [class field]) + (language.throw mistaken-field-owner + (format " Field: " field-name "\n" + " Owner Class: " (Class::getName [] owner) "\n" + "Target Class: " class-name "\n")))) + + (#e.Error _) + (language.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])]))) + (language.throw not-a-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)] + _ (language.assert type-parameter-mismatch + (format "Expected: " (%i (.int num-params)) "\n" + " Actual: " (%i (.int num-vars)) "\n" + " Class: " _class-name "\n" + " Type: " (%type objectT)) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dict.from-list text.Hash<Text>)))) + + _ + (language.throw non-object objectT))) + fieldT (java-type-to-lux-type mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal [modifiers])])) + (language.throw not-a-virtual-field (format class-name "#" field-name))))) + +(def: (static//get proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> + [[fieldT final?] (static-field class field)] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field))))) + + _ + (language.throw /.invalid-syntax [proc args])) + + _ + (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + +(def: (static//put proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> + [_ (typeA.infer Any) + [fieldT final?] (static-field class field) + _ (language.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA)))) + + _ + (language.throw /.invalid-syntax [proc args])) + + _ + (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + +(def: (virtual//get proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [fieldT final?] (virtual-field class field objectT)] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) objectA)))) + + _ + (language.throw /.invalid-syntax [proc args])) + + _ + (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + +(def: (virtual//put proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC valueC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad<Meta> + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [fieldT final?] (virtual-field class field objectT) + _ (language.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) + + _ + (language.throw /.invalid-syntax [proc args])) + + _ + (language.throw /.incorrect-extension-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 [] (:coerce Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType [] (:coerce 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 [] (:coerce GenericArrayType type)))] + (wrap (format componentP "[]"))) + + ## else + (language.throw cannot-convert-to-a-parameter (jvm-type-name type)))) + +(type: Method-style + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-style arg-classes method) + (-> (Class Object) Text Method-style (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-style + #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-parameter + (-> Nat Type) + (|>> (n/* +2) inc #.Parameter)) + +(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-parameter)))) + +(def: (method-to-type method-style method) + (-> Method-style Method (Meta [Type (List Type)])) + (let [owner (Method::getDeclaringClass [] method) + owner-name (Class::getName [] owner) + owner-tvars (case method-style + #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-style + #Static + inputsT + + _ + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) + inputsT))) + outputT)]] + (wrap [methodT exceptionsT])))) + +(type: (Evaluation a) + (#Pass a) + (#Hint a) + #Fail) + +(do-template [<name> <tag>] + [(def: <name> + (All [a] (-> (Evaluation a) (Maybe a))) + (|>> (case> (<tag> output) + (#.Some output) + + _ + #.None)))] + + [pass! #Pass] + [hint! #Hint] + ) + +(def: (method-candidate class-name method-name method-style arg-classes) + (-> Text Text Method-style (List Text) (Meta [Type (List Type)])) + (do macro.Monad<Meta> + [class (load-class class-name) + candidates (|> class + (Class::getDeclaredMethods []) + array.to-list + (monad.map @ (: (-> Method (Meta (Evaluation Method))) + (function (_ method) + (do @ + [passes? (check-method class method-name method-style arg-classes method)] + (wrap (cond passes? + (#Pass method) + + (text/= method-name (Method::getName [] method)) + (#Hint method) + + ## else + #Fail)))))))] + (case (list.search-all pass! candidates) + #.Nil + (language.throw no-candidates [class-name method-name + (|> candidates + (list.search-all hint!) + (list/map (method-to-type method-style)))]) + + (#.Cons method #.Nil) + (method-to-type method-style method) + + candidates + (language.throw too-many-candidates [class-name method-name + (list/map (method-to-type method-style) candidates)])))) + +(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-method "<init>") + +(def: (constructor-candidate 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.search-all pass! candidates) + #.Nil + (language.throw no-candidates [class-name ..constructor-method + (|> candidates + (list.search-all hint!) + (list/map constructor-to-type))]) + + (#.Cons constructor #.Nil) + (constructor-to-type constructor) + + candidates + (language.throw too-many-candidates [class-name ..constructor-method + (list/map constructor-to-type candidates)])))) + +(def: (decorate-inputs typesT inputsA) + (-> (List Text) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip2 (list/map analysisL.text typesT)) + (list/map (function (_ [type value]) + (analysisL.product-analysis (list type value)))))) + +(def: (invoke//static proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Static argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (language.throw /.invalid-syntax [proc args])))) + +(def: (invoke//virtual proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method objectC argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate 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.Extension proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) + + _ + (language.throw /.invalid-syntax [proc args])))) + +(def: (invoke//special proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]]) + (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) + (#e.Success [_ [class method objectC argsTC _]]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Special argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (language.throw /.invalid-syntax [proc args])))) + +(def: (invoke//interface proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class-name method objectC argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] + class (load-class class-name) + _ (language.assert non-interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) + [methodT exceptionsT] (method-candidate class-name method #Interface argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Extension proc + (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) + (decorate-inputs argsT argsA))))) + + _ + (language.throw /.invalid-syntax [proc args])))) + +(def: (invoke//constructor proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text (List [Text Code])]) + (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class argsTC]) + (do macro.Monad<Meta> + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (constructor-candidate class argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] + (wrap (#analysisL.Extension proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) + + _ + (language.throw /.invalid-syntax [proc args])))) + +(def: member-procs + /.Bundle + (<| (/.prefix "member") + (|> (dict.new text.Hash<Text>) + (dict.merge (<| (/.prefix "static") + (|> (dict.new text.Hash<Text>) + (/.install "get" static//get) + (/.install "put" static//put)))) + (dict.merge (<| (/.prefix "virtual") + (|> (dict.new text.Hash<Text>) + (/.install "get" virtual//get) + (/.install "put" virtual//put)))) + (dict.merge (<| (/.prefix "invoke") + (|> (dict.new text.Hash<Text>) + (/.install "static" invoke//static) + (/.install "virtual" invoke//virtual) + (/.install "special" invoke//special) + (/.install "interface" invoke//interface) + (/.install "constructor" invoke//constructor) + ))) + ))) + +(def: #export extensions + /.Bundle + (<| (/.prefix "jvm") + (|> (dict.new text.Hash<Text>) + (dict.merge conversion-procs) + (dict.merge int-procs) + (dict.merge long-procs) + (dict.merge float-procs) + (dict.merge double-procs) + (dict.merge char-procs) + (dict.merge array-procs) + (dict.merge object-procs) + (dict.merge member-procs) + ))) diff --git a/stdlib/source/lux/language/compiler/extension/bundle.lux b/stdlib/source/lux/language/compiler/extension/bundle.lux new file mode 100644 index 000000000..4e011d2ca --- /dev/null +++ b/stdlib/source/lux/language/compiler/extension/bundle.lux @@ -0,0 +1,31 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [text] + text/format + (collection [list "list/" Functor<List>] + ["dict" dictionary #+ Dictionary]))) + [//]) + +(exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat}) + (ex.report ["Extension" (%t name)] + ["Expected arity" (|> arity .int %i)] + ["Actual arity" (|> args .int %i)])) + +(exception: #export (invalid-syntax {name Text}) + (ex.report ["Extension" name])) + +## [Utils] +(def: #export (install name anonymous) + (All [s i o] + (-> Text (-> Text (//.Handler s i o)) + (-> (//.Bundle s i o) (//.Bundle s i o)))) + (dict.put name anonymous)) + +(def: #export (prefix prefix) + (All [s i o] + (-> Text (-> (//.Bundle s i o) (//.Bundle s i o)))) + (|>> dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash<Text>))) diff --git a/stdlib/source/lux/language/compiler/extension/synthesis.lux b/stdlib/source/lux/language/compiler/extension/synthesis.lux new file mode 100644 index 000000000..48073d012 --- /dev/null +++ b/stdlib/source/lux/language/compiler/extension/synthesis.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (collection ["dict" dictionary #+ Dictionary]))) + [//]) + +(def: #export defaults + (Dictionary Text //.Synthesis) + (dict.new text.Hash<Text>)) diff --git a/stdlib/source/lux/language/compiler/extension/translation.lux b/stdlib/source/lux/language/compiler/extension/translation.lux new file mode 100644 index 000000000..ae05fd61c --- /dev/null +++ b/stdlib/source/lux/language/compiler/extension/translation.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (collection ["dict" dictionary #+ Dictionary]))) + [//]) + +(def: #export defaults + (Dictionary Text //.Translation) + (dict.new text.Hash<Text>)) |