From 86f2337ef398f38e76b4763b3941785d63e4caa9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 19 Feb 2016 00:35:07 -0400 Subject: - Added support for bounded polymorphism. - Fixed some minor JVM-interop bugs. --- src/lux/analyser/host.clj | 53 ++++++++++++++++++--------------------- src/lux/analyser/parser.clj | 60 ++++++++++++++++++++++++++++++++++----------- src/lux/base.clj | 4 +++ src/lux/host/generics.clj | 43 +++++++++++++++++++++++--------- src/lux/type/host.clj | 8 +++--- 5 files changed, 110 insertions(+), 58 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 11914b1fa..18b4a9dd6 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -4,7 +4,8 @@ ;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.host - (:require (clojure [template :refer [do-template]]) + (:require (clojure [template :refer [do-template]] + [string :as string]) clojure.core.match clojure.core.match.array (lux [base :as & :refer [|let |do return* return fail |case assert!]] @@ -464,7 +465,7 @@ (&/$GenericTypeVar var-name) "java.lang.Object" - (&/$GenericWildcard) + (&/$GenericWildcard _) "java.lang.Object" (&/$GenericClass name params) @@ -505,7 +506,7 @@ (&/$GenericTypeVar var-name) "[Ljava.lang.Object;" - (&/$GenericWildcard) + (&/$GenericWildcard _) "[Ljava.lang.Object;") )) @@ -536,8 +537,8 @@ (|do [=param (generic-class->type env param)] (return (&/$DataT &host-type/array-data-tag (&/|list =param)))) - (&/$GenericWildcard) - (return (&/$ExT &/$Nil (&/$BoundT 1))) + (&/$GenericWildcard _) + (return (&/$ExQ &/$Nil (&/$BoundT 1))) )) (defn gen-super-env [class-env supers class-decl] @@ -546,7 +547,7 @@ (|case (&/|some (fn [super] (|let [[super-name super-params] super] (if (= class-name super-name) - (&/$Some (&/zip2 class-vars super-params)) + (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) &/$None))) supers) (&/$None) @@ -560,16 +561,21 @@ vars+gtypes) ))) +(defn ^:private make-type-env [type-params] + "(-> (List TypeParam) (Lux (List [Text Type])))" + (&/map% (fn [gvar] + (|do [:let [[gvar-name _] gvar] + ex &type/existential] + (return (&/T [gvar-name ex])))) + type-params)) + (defn ^:private analyse-method [analyse class-decl class-env all-supers method] "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" (|let [[?cname ?cparams] class-decl class-type (&/$DataT ?cname (&/|map &/|second class-env))] (|case method (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|do [method-env (&/map% (fn [gvar] - (|do [ex &type/existential] - (return (&/T [gvar ex])))) - ?gvars) + (|do [method-env (make-type-env ?gvars) :let [full-env (&/|++ class-env method-env)] :let [output-type &/$UnitT] =ctor-args (&/map% (fn [ctor-arg] @@ -590,10 +596,7 @@ (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (&/map% (fn [gvar] - (|do [ex &type/existential] - (return (&/T [gvar ex])))) - ?gvars) + (|do [method-env (make-type-env ?gvars) :let [full-env (&/|++ class-env method-env)] output-type (generic-class->type full-env ?output) =body (&/with-type-env full-env @@ -609,10 +612,7 @@ (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) (|do [super-env (gen-super-env class-env all-supers ?class-decl) - method-env (&/map% (fn [gvar] - (|do [ex &type/existential] - (return (&/T [gvar ex])))) - ?gvars) + method-env (make-type-env ?gvars) :let [full-env (&/|++ super-env method-env)] output-type (generic-class->type full-env ?output) =body (&/with-type-env full-env @@ -627,10 +627,7 @@ (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (&/map% (fn [gvar] - (|do [ex &type/existential] - (return (&/T [gvar ex])))) - ?gvars) + (|do [method-env (make-type-env ?gvars) :let [full-env method-env] output-type (generic-class->type full-env ?output) =body (&/with-type-env full-env @@ -716,15 +713,13 @@ (&/with-closure (|do [module &/get-module-name :let [[?name ?params] class-decl - full-name (str module "." ?name) + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) all-supers (&/$Cons super-class interfaces)] - class-env (&/map% (fn [gvar] - (|do [ex &type/existential] - (return (&/T [gvar ex])))) - ?params) + class-env (make-type-env ?params) =fields (&/map% (partial analyse-field analyse class-env) ?fields) _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) _ (check-method-completion all-supers =methods) _ (compile-token (&&/$jvm-class (&/T [class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None]))) :let [_ (println 'DEF full-name)]] @@ -757,7 +752,7 @@ scope &/get-scope-name :let [name (&host/location (&/|tail scope)) class-decl (&/T [name &/$Nil]) - anon-class (str module "." name) + anon-class (str (string/replace module "/" ".") "." name) anon-class-type (&/$DataT anon-class &/$Nil)] =ctor-args (&/map% (fn [ctor-arg] (|let [[arg-type arg-term] ctor-arg] diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index 980e23535..dca09bb61 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -9,6 +9,8 @@ clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]]))) +(declare parse-gclass) + ;; [Parsers] (defn parse-tag [ast] (|case ast @@ -26,19 +28,44 @@ _ (fail (str "[Analyser Error] Not text: " (&/show-ast ast))))) +(defn parse-type-param [ast] + (|case ast + [_ (&/$TupleS (&/$Cons [_ (&/$TextS tname)] (&/$Cons [_ (&/$TupleS ?bounds)] (&/$Nil))))] + (|do [=bounds (&/map% parse-gclass ?bounds)] + (return (&/T [tname =bounds]))) + + _ + (fail (str "[Analyser Error] Not a type-param: " (&/show-ast ast))))) + (defn parse-gclass-decl [ast] (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS class-name)] (&/$Cons [_ (&/$TupleS args)] (&/$Nil))))] - (|do [=args (&/map% parse-text args)] + (|do [=args (&/map% parse-type-param args)] (return (&/T [class-name =args]))) _ (fail (str "[Analyser Error] Not generic class declaration: " (&/show-ast ast))))) +(defn parse-bound-kind [ast] + (|case ast + [_ (&/$TextS "<")] + (return &/$UpperBound) + + [_ (&/$TextS ">")] + (return &/$LowerBound) + + _ + (fail (str "[Analyser Error] Not a bound kind: " (&/show-ast ast))))) + (defn parse-gclass [ast] (|case ast - [_ (&/$TextS "*")] - (return (&/$GenericWildcard &/unit-tag)) + [_ (&/$TupleS (&/$Cons [_ (&/$TextS "*")] (&/$Nil)))] + (return (&/$GenericWildcard &/$None)) + + [_ (&/$TupleS (&/$Cons [_ (&/$TextS "*")] (&/$Cons ?bound-kind (&/$Cons ?bound (&/$Nil)))))] + (|do [=bound-kind (parse-bound-kind ?bound-kind) + =bound (parse-gclass ?bound)] + (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) [_ (&/$TextS var-name)] (return (&/$GenericTypeVar var-name)) @@ -135,7 +162,8 @@ (&/$Cons [_ (&/$TupleS gvars)] (&/$Cons [_ (&/$TupleS exceptions)] (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output (&/$Nil))))))))] + (&/$Cons output + (&/$Nil))))))))] (|do [=anns (&/map% parse-ann anns) =gvars (&/map% parse-text gvars) =exceptions (&/map% parse-gclass exceptions) @@ -201,10 +229,11 @@ (&/$Cons [_ (&/$TupleS exceptions)] (&/$Cons [_ (&/$TupleS inputs)] (&/$Cons [_ (&/$TupleS ?ctor-args)] - (&/$Cons body (&/$Nil)))))))))))] + (&/$Cons body + (&/$Nil)))))))))))] (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) =anns (&/map% parse-ann anns) - =gvars (&/map% parse-text gvars) + =gvars (&/map% parse-type-param gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =ctor-args (&/map% parse-ctor-arg ?ctor-args)] @@ -225,10 +254,11 @@ (&/$Cons [_ (&/$TupleS exceptions)] (&/$Cons [_ (&/$TupleS inputs)] (&/$Cons output - (&/$Cons body (&/$Nil)))))))))))))] + (&/$Cons body + (&/$Nil)))))))))))))] (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) =anns (&/map% parse-ann anns) - =gvars (&/map% parse-text gvars) + =gvars (&/map% parse-type-param gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] @@ -248,11 +278,12 @@ (&/$Cons [_ (&/$TupleS exceptions)] (&/$Cons [_ (&/$TupleS inputs)] (&/$Cons output - (&/$Cons body (&/$Nil))))))))))))] + (&/$Cons body + (&/$Nil))))))))))))] (|do [=name (parse-text ?name) =class-decl (parse-gclass-decl ?class-decl) =anns (&/map% parse-ann anns) - =gvars (&/map% parse-text gvars) + =gvars (&/map% parse-type-param gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] @@ -272,10 +303,11 @@ (&/$Cons [_ (&/$TupleS exceptions)] (&/$Cons [_ (&/$TupleS inputs)] (&/$Cons output - (&/$Cons body (&/$Nil))))))))))))] + (&/$Cons body + (&/$Nil))))))))))))] (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) =anns (&/map% parse-ann anns) - =gvars (&/map% parse-text gvars) + =gvars (&/map% parse-type-param gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] @@ -297,7 +329,7 @@ (&/$Nil))))))))))] (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) =anns (&/map% parse-ann anns) - =gvars (&/map% parse-text gvars) + =gvars (&/map% parse-type-param gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] @@ -319,7 +351,7 @@ (&/$Nil))))))))))] (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) =anns (&/map% parse-ann anns) - =gvars (&/map% parse-text gvars) + =gvars (&/map% parse-type-param gvars) =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 581930e3a..5e46694e2 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -152,6 +152,10 @@ "host"]) ;; Compiler +(defvariant + ("UpperBound" 0) + ("LowerBound" 0)) + (defvariant ("GenericTypeVar" 1) ("GenericClass" 2) diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj index 0d34fe1a4..53cc98e6e 100644 --- a/src/lux/host/generics.clj +++ b/src/lux/host/generics.clj @@ -11,6 +11,8 @@ (lux [base :as & :refer [|do return* return fail fail* |let |case]])) (:import java.util.regex.Pattern)) +(declare gclass->signature) + (do-template [ ] (let [regex (-> Pattern/quote re-pattern)] (defn [old] @@ -46,10 +48,23 @@ (|let [[super-name super-params] super] super-name)) -(defn class-decl-params->signature [params] +(defn formal-type-parameter->signature [param] + (|let [[pname pbounds] param] + (|case pbounds + (&/$Nil) + pname + + _ + (->> pbounds + (&/|map (fn [pbound] (str ": " (gclass->signature pbound)))) + (&/|interpose " ") + (str pname " ")) + ))) + +(defn formal-type-parameters->signature [params] (if (&/|empty? params) "" - (str "<" (->> params (&/|interpose " ") (&/fold str "")) ">"))) + (str "<" (->> params (&/|map formal-type-parameter->signature) (&/|interpose " ") (&/fold str "")) ">"))) (defn gclass->signature [super] "(-> GenericClass Text)" @@ -57,8 +72,14 @@ (&/$GenericTypeVar name) (str "T" name ";") - (&/$GenericWildcard) + (&/$GenericWildcard (&/$None)) "*" + + (&/$GenericWildcard (&/$Some [(&/$UpperBound) ?bound])) + (str "+" (gclass->signature ?bound)) + + (&/$GenericWildcard (&/$Some [(&/$LowerBound) ?bound])) + (str "-" (gclass->signature ?bound)) (&/$GenericClass name params) (case name @@ -67,7 +88,7 @@ "byte" "B" "short" "S" "int" "I" - "long" "L" + "long" "J" "float" "F" "double" "D" "char" "C" @@ -90,7 +111,7 @@ (defn gclass-decl->signature [class-decl supers] "(-> GenericClassDecl (List GenericSuperClassDecl) Text)" (|let [[class-name class-vars] class-decl - vars-section (class-decl-params->signature class-vars) + vars-section (formal-type-parameters->signature class-vars) super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))] (str vars-section super-section))) @@ -101,7 +122,7 @@ (&/$GenericTypeVar name) object-simple-signature - (&/$GenericWildcard) + (&/$GenericWildcard _) object-simple-signature (&/$GenericClass name params) @@ -119,7 +140,7 @@ (&/$GenericTypeVar name) (->bytecode-class-name "java.lang.Object") - (&/$GenericWildcard) + (&/$GenericWildcard _) (->bytecode-class-name "java.lang.Object") (&/$GenericClass name params) @@ -139,7 +160,7 @@ (&/$GenericTypeVar name) object-bc-name - (&/$GenericWildcard) + (&/$GenericWildcard _) object-bc-name (&/$GenericClass name params) @@ -157,7 +178,7 @@ (&/$GenericTypeVar name) object-bc-name - (&/$GenericWildcard) + (&/$GenericWildcard _) object-bc-name (&/$GenericClass name params) @@ -169,9 +190,7 @@ (defn method-signatures [method-decl] (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) - generic-signature (str (if (&/|empty? =gvars) - "" - (str "<" (->> =gvars (&/|interpose " ") (&/fold str "")) ">")) + generic-signature (str (formal-type-parameters->signature =gvars) "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" (gclass->signature =output) (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 9717b0e75..096fb2182 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -271,8 +271,10 @@ (instance? WildcardType gtype) (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] - (gtype->gclass bound) - &/$GenericWildcard))) + (&/$GenericWildcard (&/$Some (&/T &/$UpperBound (gtype->gclass bound)))) + (if-let [bound (->> ^WildcardType gtype .getLowerBounds seq first)] + (&/$GenericWildcard (&/$Some (&/T &/$LowerBound (gtype->gclass bound)))) + (&/$GenericWildcard &/$None))))) (let [generic-type-sig "Ljava/lang/Object;"] (defn gclass->sig [gclass] @@ -297,6 +299,6 @@ (&/$GenericTypeVar ?vname) generic-type-sig - (&/$GenericWildcard) + (&/$GenericWildcard _) generic-type-sig ))) -- cgit v1.2.3