aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/analyser.clj2
-rw-r--r--src/lux/analyser/base.clj9
-rw-r--r--src/lux/analyser/case.clj4
-rw-r--r--src/lux/analyser/lux.clj146
-rw-r--r--src/lux/analyser/module.clj31
-rw-r--r--src/lux/analyser/record.clj154
6 files changed, 139 insertions, 207 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 9a57191f5..d17eeea2a 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -499,7 +499,7 @@
(return (&/|list (&/T (&/V &&/$text ?value) exo-type))))
(&/$TupleS ?elems)
- (&&lux/analyse-tuple analyse exo-type ?elems)
+ (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems)
(&/$RecordS ?elems)
(&&lux/analyse-record analyse exo-type ?elems)
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 7f7980e76..e27b2e42e 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -130,15 +130,18 @@
(|let [[_ type] syntax+]
type))
-(defn analyse-1 [analyse exo-type elem]
- (|do [output (analyse exo-type elem)]
- (|case output
+(defn cap-1 [action]
+ (|do [result action]
+ (|case result
(&/$Cons x (&/$Nil))
(return x)
_
(fail "[Analyser Error] Can't expand to other than 1 element."))))
+(defn analyse-1 [analyse exo-type elem]
+ (cap-1 (analyse exo-type elem)))
+
(defn analyse-1+ [analyse ?token]
(&type/with-var
(fn [$var]
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index f2afdb0e9..7226b98e4 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -178,8 +178,8 @@
(fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*))))))
(&/$RecordS pairs)
- (|do [?members (&&record/order-record pairs)]
- (analyse-pattern value-type (&/T meta (&/V &/$TupleS ?members)) kont))
+ (|do [[rec-members rec-type] (&&record/order-record pairs)]
+ (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont))
(&/$TagS ?ident)
(|do [;; :let [_ (println "#00" (&/ident->text ?ident))]
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 39eda451f..a6f41c9fd 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -18,35 +18,84 @@
[module :as &&module]
[record :as &&record])))
+;; [Utils]
+(defn ^:private count-univq [type]
+ "(-> Type Int)"
+ (|case type
+ (&/$UnivQ env type*)
+ (inc (count-univq type*))
+
+ _
+ 0))
+
+(defn ^:private next-bound-type [type]
+ "(-> Type Type)"
+ (&type/Bound$ (->> (count-univq type) (* 2) (+ 1))))
+
+(defn ^:private embed-inferred-input [input output]
+ "(-> Type Type Type)"
+ (|case output
+ (&/$UnivQ env output*)
+ (&type/Univ$ env (embed-inferred-input input output*))
+
+ _
+ (&type/Lambda$ input output)))
+
;; [Exports]
-(defn analyse-tuple [analyse exo-type ?elems]
- (|do [unknown? (&type/unknown? exo-type)]
- (if unknown?
- (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)]
- (return =analysis))
- ?elems)
- _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))]
- (return (&/|list (&/T (&/V &&/$tuple =elems)
- exo-type))))
- (|do [exo-type* (&type/actual-type exo-type)]
- (|case exo-type*
- (&/$TupleT ?members)
- (|do [=elems (&/map2% (fn [elem-t elem]
- (&&/analyse-1 analyse elem-t elem))
- ?members ?elems)]
- (return (&/|list (&/T (&/V &&/$tuple =elems)
- exo-type))))
-
- (&/$UnivQ _)
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)]
- (analyse-tuple analyse exo-type** ?elems))))
+(defn analyse-tuple [analyse ?exo-type ?elems]
+ (|case ?exo-type
+ (&/$Left exo-type)
+ (|do [;; :let [_ (println 'analyse-tuple/$Left (&type/show-type exo-type))]
+ exo-type* (&type/actual-type exo-type)]
+ (|case exo-type*
+ (&/$UnivQ _)
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)
+ [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems))
+ =var (&type/resolve-type $var)
+ inferred-type (|case =var
+ (&/$VarT iid)
+ (|do [:let [=var* (next-bound-type tuple-type)]
+ _ (&type/set-var iid =var*)
+ tuple-type* (&type/clean $var tuple-type)]
+ (return (&type/Univ$ (&/|list) tuple-type*)))
+
+ _
+ (&type/clean $var tuple-type))]
+ (return (&/|list (&/T tuple-analysis inferred-type))))))
- _
- (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]"))
- ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]"))
- )))))
+ _
+ (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems)))
+
+ (&/$Right exo-type)
+ (|do [unknown? (&type/unknown? exo-type)]
+ (if unknown?
+ (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)]
+ (return =analysis))
+ ?elems)
+ _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))]
+ (return (&/|list (&/T (&/V &&/$tuple =elems)
+ exo-type))))
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (|case exo-type*
+ (&/$TupleT ?members)
+ (|do [=elems (&/map2% (fn [elem-t elem]
+ (&&/analyse-1 analyse elem-t elem))
+ ?members ?elems)]
+ (return (&/|list (&/T (&/V &&/$tuple =elems)
+ exo-type))))
+
+ (&/$UnivQ _)
+ (|do [$var &type/existential
+ exo-type** (&type/apply-type exo-type* $var)
+ [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))]
+ (return (&/|list (&/T tuple-analysis exo-type))))
+
+ _
+ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]"))
+ ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]"))
+ ))))))
(defn with-attempt [m-value on-error]
(fn [state]
@@ -61,13 +110,13 @@
(|do [output (with-attempt
(|case ?values
(&/$Nil)
- (analyse-tuple analyse exo-type (&/|list))
+ (analyse-tuple analyse (&/V &/$Right exo-type) (&/|list))
(&/$Cons ?value (&/$Nil))
(analyse exo-type ?value)
_
- (analyse-tuple analyse exo-type ?values))
+ (analyse-tuple analyse (&/V &/$Right exo-type) ?values))
(fn [err]
(fail (str err "\n"
'analyse-variant-body " " (&type/show-type exo-type)
@@ -121,8 +170,19 @@
(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 [members (&&record/order-record ?elems)]
- (analyse-tuple analyse exo-type members)))
+ (|do [[rec-members rec-type] (&&record/order-record ?elems)]
+ (|case exo-type
+ (&/$VarT id)
+ (|do [? (&type/bound? id)]
+ (if ?
+ (analyse-tuple analyse (&/V &/$Right exo-type) rec-members)
+ (|do [[tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members))
+ _ (&type/check exo-type tuple-type)]
+ (return (&/|list (&/T tuple-analysis exo-type))))))
+
+ _
+ (analyse-tuple analyse (&/V &/$Right exo-type) rec-members)
+ )))
(defn ^:private analyse-global [analyse exo-type module name]
(|do [[[r-module r-name] $def] (&&module/find-def module name)
@@ -301,24 +361,6 @@
(return (&/|list (&/T (&/V &&/$case (&/T =value =match))
exo-type)))))
-(defn ^:private count-univq [type]
- "(-> Type Int)"
- (|case type
- (&/$UnivQ env type*)
- (inc (count-univq type*))
-
- _
- 0))
-
-(defn ^:private embed-inferred-input [input output]
- "(-> Type Type Type)"
- (|case output
- (&/$UnivQ env output*)
- (&type/Univ$ env (embed-inferred-input input output*))
-
- _
- (&type/Lambda$ input output)))
-
(defn analyse-lambda* [analyse exo-type ?self ?arg ?body]
(|case exo-type
(&/$VarT id)
@@ -336,7 +378,7 @@
=output (&type/resolve-type $output)
inferred-type (|case =input
(&/$VarT iid)
- (|do [:let [=input* (&type/Bound$ (->> (count-univq =output) (* 2) (+ 1)))]
+ (|do [:let [=input* (next-bound-type =output)]
_ (&type/set-var iid =input*)
=output* (&type/clean $input =output)
=output** (&type/clean $output =output*)]
@@ -424,7 +466,9 @@
(do ;; (println 'DEF (str module-name ";" ?name))
(|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
:let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name))
- _ (println 'DEF (str module-name ";" ?name))]]
+ [def-analysis def-type] =value
+ _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type)
+ )]]
(return (&/|list)))))
))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 8c27fc08d..aaed26a7a 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -343,20 +343,17 @@
nil))
(fail* (str "[Lux Error] Unknown module: " module))))))
-(defn tag-index [module tag-name]
- "(-> Text Text (Lux Int))"
- (fn [state]
- (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))]
- (return* state (aget idx+tags 0))
- (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
- (fail* (str "[Module Error] Unknown module: " module)))))
-
-(defn tag-group [module tag-name]
- "(-> Text Text (Lux (List Ident)))"
- (fn [state]
- (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))]
- (return* state (aget idx+tags 1))
- (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
- (fail* (str "[Module Error] Unknown module: " module)))))
+(do-template [<name> <idx> <doc>]
+ (defn <name> [module tag-name]
+ <doc>
+ (fn [state]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [^objects idx+tags+type (&/|get tag-name (&/get$ $tags =module))]
+ (return* state (aget idx+tags+type <idx>))
+ (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
+ (fail* (str "[Module Error] Unknown module: " module)))))
+
+ tag-index 0 "(-> Text Text (Lux Int))"
+ tag-group 1 "(-> Text Text (Lux (List Ident)))"
+ tag-type 2 "(-> Text Text (Lux Type))"
+ )
diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj
index 8b70bbcb4..0f860888b 100644
--- a/src/lux/analyser/record.clj
+++ b/src/lux/analyser/record.clj
@@ -6,139 +6,26 @@
(ns lux.analyser.record
(:require clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [deftags |let |do return fail |case]])
+ (lux [base :as & :refer [deftags |let |do return fail |case]]
+ [type :as &type])
(lux.analyser [base :as &&]
[module :as &&module])))
-;; [Tags]
-(deftags ""
- "bool"
- "int"
- "real"
- "char"
- "text"
- "variant"
- "tuple"
- "apply"
- "case"
- "lambda"
- "ann"
- "def"
- "declare-macro"
- "var"
- "captured"
-
- "jvm-getstatic"
- "jvm-getfield"
- "jvm-putstatic"
- "jvm-putfield"
- "jvm-invokestatic"
- "jvm-instanceof"
- "jvm-invokevirtual"
- "jvm-invokeinterface"
- "jvm-invokespecial"
- "jvm-null?"
- "jvm-null"
- "jvm-new"
- "jvm-new-array"
- "jvm-aastore"
- "jvm-aaload"
- "jvm-class"
- "jvm-interface"
- "jvm-try"
- "jvm-throw"
- "jvm-monitorenter"
- "jvm-monitorexit"
- "jvm-program"
-
- "jvm-iadd"
- "jvm-isub"
- "jvm-imul"
- "jvm-idiv"
- "jvm-irem"
- "jvm-ieq"
- "jvm-ilt"
- "jvm-igt"
-
- "jvm-ceq"
- "jvm-clt"
- "jvm-cgt"
-
- "jvm-ladd"
- "jvm-lsub"
- "jvm-lmul"
- "jvm-ldiv"
- "jvm-lrem"
- "jvm-leq"
- "jvm-llt"
- "jvm-lgt"
-
- "jvm-fadd"
- "jvm-fsub"
- "jvm-fmul"
- "jvm-fdiv"
- "jvm-frem"
- "jvm-feq"
- "jvm-flt"
- "jvm-fgt"
-
- "jvm-dadd"
- "jvm-dsub"
- "jvm-dmul"
- "jvm-ddiv"
- "jvm-drem"
- "jvm-deq"
- "jvm-dlt"
- "jvm-dgt"
-
- "jvm-d2f"
- "jvm-d2i"
- "jvm-d2l"
-
- "jvm-f2d"
- "jvm-f2i"
- "jvm-f2l"
-
- "jvm-i2b"
- "jvm-i2c"
- "jvm-i2d"
- "jvm-i2f"
- "jvm-i2l"
- "jvm-i2s"
-
- "jvm-l2d"
- "jvm-l2f"
- "jvm-l2i"
-
- "jvm-iand"
- "jvm-ior"
- "jvm-ixor"
- "jvm-ishl"
- "jvm-ishr"
- "jvm-iushr"
-
- "jvm-land"
- "jvm-lor"
- "jvm-lxor"
- "jvm-lshl"
- "jvm-lshr"
- "jvm-lushr"
-
- )
-
;; [Exports]
(defn order-record [pairs]
"(-> (List (, Syntax Syntax)) (Lux (List Syntax)))"
- (|do [tag-group (|case pairs
- (&/$Nil)
- (return (&/|list))
-
- (&/$Cons [[_ (&/$TagS tag1)] _] _)
- (|do [[module name] (&&/resolved-ident tag1)]
- (&&module/tag-group module name))
-
- _
- (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))
+ (|do [[tag-group tag-type] (|case pairs
+ (&/$Nil)
+ (return (&/T (&/|list) &type/Unit))
+
+ (&/$Cons [[_ (&/$TagS tag1)] _] _)
+ (|do [[module name] (&&/resolved-ident tag1)
+ tags (&&module/tag-group module name)
+ type (&&module/tag-type module name)]
+ (return (&/T tags type)))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))
=pairs (&/map% (fn [kv]
(|case kv
[[_ (&/$TagS k)] v]
@@ -147,9 +34,10 @@
_
(fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")))
- pairs)]
- (&/map% (fn [tag]
- (if-let [member (&/|get tag =pairs)]
- (return member)
- (fail (str "[Analyser Error] Unknown tag: " tag))))
- (&/|map &/ident->text tag-group))))
+ pairs)
+ =members (&/map% (fn [tag]
+ (if-let [member (&/|get tag =pairs)]
+ (return member)
+ (fail (str "[Analyser Error] Unknown tag: " tag))))
+ (&/|map &/ident->text tag-group))]
+ (return (&/T =members tag-type))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 07:38:04 +0000