aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2016-02-19 00:35:07 -0400
committerEduardo Julian2016-02-19 00:35:07 -0400
commit86f2337ef398f38e76b4763b3941785d63e4caa9 (patch)
tree62a1a31f6ca834af20b0a94776b58738653ef1af
parentaeb69c497848a238ba78af7d92599646c622b9dd (diff)
- Added support for bounded polymorphism.
- Fixed some minor JVM-interop bugs.
-rw-r--r--src/lux/analyser/host.clj53
-rw-r--r--src/lux/analyser/parser.clj60
-rw-r--r--src/lux/base.clj4
-rw-r--r--src/lux/host/generics.clj43
-rw-r--r--src/lux/type/host.clj8
5 files changed, 110 insertions, 58 deletions
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
@@ -153,6 +153,10 @@
;; Compiler
(defvariant
+ ("UpperBound" 0)
+ ("LowerBound" 0))
+
+(defvariant
("GenericTypeVar" 1)
("GenericClass" 2)
("GenericArray" 1)
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 [<name> <old-sep> <new-sep>]
(let [regex (-> <old-sep> Pattern/quote re-pattern)]
(defn <name> [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
)))