aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/lux/analyser.clj31
-rw-r--r--src/lux/analyser/base.clj5
-rw-r--r--src/lux/analyser/lux.clj106
3 files changed, 98 insertions, 44 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index d17eeea2a..a9689a9d0 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -43,6 +43,23 @@
_
(fail (str "[Analyser Error] Not a tag: " (&/show-ast ast)))))
+(defn analyse-variant+ [analyser exo-type ident values]
+ (|do [[module tag-name] (&/normalize ident)
+ idx (&&module/tag-index module tag-name)]
+ (|case exo-type
+ (&/$VarT id)
+ (|do [? (&type/bound? id)]
+ (if (or ? (&&/type-tag? module tag-name))
+ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values)
+ (|do [wanted-type (&&module/tag-type module tag-name)
+ [variant-analysis variant-type] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values))
+ _ (&type/check exo-type variant-type)]
+ (return (&/|list (&/T variant-analysis exo-type))))))
+
+ _
+ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values)
+ )))
+
(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token]
(|case token
;; Arrays
@@ -505,9 +522,7 @@
(&&lux/analyse-record analyse exo-type ?elems)
(&/$TagS ?ident)
- (|do [[module tag-name] (&/normalize ?ident)
- idx (&&module/tag-index module tag-name)]
- (&&lux/analyse-variant analyse exo-type idx (&/|list)))
+ (analyse-variant+ analyse exo-type ?ident (&/|list))
(&/$SymbolS _ "_jvm_null")
(&&host/analyse-jvm-null analyse exo-type)
@@ -573,16 +588,10 @@
(&/with-expected-type exo-type
(|case token
[meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))]
- (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)
+ (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx ?values)
[meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))]
- (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))]
- [module tag-name] (&/normalize ?ident)
- ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))]
- idx (&&module/tag-index module tag-name)
- ;; :let [_ (println 'analyse-ast/_2 idx)]
- ]
- (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values))
+ (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values)
[meta (&/$FormS (&/$Cons ?fn ?args))]
(fn [state]
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index e27b2e42e..1507a3a76 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -156,3 +156,8 @@
&/get-module-name
(return ?module))]
(return (&/T module* ?name)))))
+
+(let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}]
+ (defn type-tag? [module name]
+ (and (= "lux" module)
+ (contains? tag-names name))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index a6f41c9fd..b8239d1a9 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -133,41 +133,75 @@
_
(fail "[Analyser Error] Can't expand to other than 1 element."))))
-(defn analyse-variant [analyse exo-type idx ?values]
- (|do [exo-type* (|case exo-type
- (&/$VarT ?id)
- (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
- (&type/actual-type exo-type*))
- (|do [_ (&type/set-var ?id &type/Type)]
- (&type/actual-type &type/Type))))
-
- _
- (&type/actual-type exo-type))]
- (|case exo-type*
- (&/$VariantT ?cases)
- (|case (&/|at idx ?cases)
- (&/$Some vtype)
- (|do [=value (with-attempt
- (analyse-variant-body analyse vtype ?values)
- (fn [err]
- (|do [_exo-type (&type/deref+ exo-type)]
- (fail (str err "\n"
- 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type)
- " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))]
- (return (&/|list (&/T (&/V &&/$variant (&/T idx =value))
- exo-type))))
+(defn analyse-variant [analyse ?exo-type idx ?values]
+ (|case ?exo-type
+ (&/$Left exo-type)
+ (|do [;; :let [_ (println 'analyse-variant/Left 0 (&type/show-type exo-type))]
+ exo-type* (&type/actual-type exo-type)
+ ;; :let [_ (println 'analyse-variant/Left 1 (&type/show-type exo-type*))]
+ ]
+ (|case exo-type*
+ (&/$UnivQ _)
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)
+ ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))]
+ [variant-analysis variant-type] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values))
+ ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))]
+ =var (&type/resolve-type $var)
+ ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))]
+ inferred-type (|case =var
+ (&/$VarT iid)
+ (|do [:let [=var* (next-bound-type variant-type)]
+ _ (&type/set-var iid =var*)
+ variant-type* (&type/clean $var variant-type)]
+ (return (&type/Univ$ (&/|list) variant-type*)))
- (&/$None)
- (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*))))
+ _
+ (&type/clean $var variant-type))
+ ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))]
+ ]
+ (return (&/|list (&/T variant-analysis inferred-type))))))
- (&/$UnivQ _)
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)]
- (analyse-variant analyse exo-type** idx ?values))))
-
- _
- (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))
+ _
+ (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values)))
+
+ (&/$Right exo-type)
+ ;; [_ exo-type]
+ (|do [;; :let [_ (println 'analyse-variant/Right 0 (&type/show-type exo-type))]
+ exo-type* (|case exo-type
+ (&/$VarT ?id)
+ (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
+ (&type/actual-type exo-type*))
+ (|do [_ (&type/set-var ?id &type/Type)]
+ (&type/actual-type &type/Type))))
+
+ _
+ (&type/actual-type exo-type))]
+ (|case exo-type*
+ (&/$VariantT ?cases)
+ (|case (&/|at idx ?cases)
+ (&/$Some vtype)
+ (|do [=value (with-attempt
+ (analyse-variant-body analyse vtype ?values)
+ (fn [err]
+ (|do [_exo-type (&type/deref+ exo-type)]
+ (fail (str err "\n"
+ 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type)
+ " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))]
+ (return (&/|list (&/T (&/V &&/$variant (&/T idx =value))
+ exo-type))))
+
+ (&/$None)
+ (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*))))
+
+ (&/$UnivQ _)
+ (|do [$var &type/existential
+ exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values))
+
+ _
+ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))))
(defn analyse-record [analyse exo-type ?elems]
(|do [[rec-members rec-type] (&&record/order-record ?elems)]
@@ -465,6 +499,12 @@
_
(do ;; (println 'DEF (str module-name ";" ?name))
(|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
+ ;; _ (if (and (= "lux" module-name)
+ ;; (= "Type" ?name))
+ ;; (|do [newly-defined-Type
+ ;; :let [_ (&type/redefine-type! newly-defined-Type)]]
+ ;; (return nil))
+ ;; (return nil))
:let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name))
[def-analysis def-type] =value
_ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type)