aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser.clj2
-rw-r--r--src/lux/analyser/case.clj7
-rw-r--r--src/lux/analyser/lux.clj14
-rw-r--r--src/lux/base.clj25
-rw-r--r--src/lux/type.clj389
5 files changed, 239 insertions, 198 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 7810c415b..3b6a93005 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -532,7 +532,7 @@
(|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state)
(catch Error e
(prn e)
- (assert false (prn-str 'analyse-basic-ast (&/show-ast ?token)))))
+ (assert false (prn-str 'analyse-basic-ast (&/show-ast token)))))
(&/$Right state* output)
(return* state* output)
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 395ae6976..483002adc 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -113,6 +113,9 @@
(fail "##9##")))]
(adjust-type* up type*))
+ (&/$NamedT ?name ?type)
+ (adjust-type* up ?type)
+
_
(assert false (prn 'adjust-type* (&type/show-type type)))
))
@@ -202,7 +205,7 @@
(fail "[Pattern-matching Error] Record requires record-type.")))
(&/$TagS ?ident)
- (|do [;; :let [_ (println "#00")]
+ (|do [;; :let [_ (println "#00" (&/ident->text ?ident))]
[=module =name] (&&/resolved-ident ?ident)
;; :let [_ (println "#01")]
value-type* (adjust-type value-type)
@@ -219,7 +222,7 @@
(&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident))
?values))
- (|do [;; :let [_ (println "#10" ?ident)]
+ (|do [;; :let [_ (println "#10" (&/ident->text ?ident))]
[=module =name] (&&/resolved-ident ?ident)
;; :let [_ (println "#11")]
value-type* (adjust-type value-type)
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 79b804088..8a79e0494 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -401,6 +401,7 @@
;; (when (= "PList/Dict" ?name)
;; (prn 'DEF ?name (&/show-ast ?value)))
(|do [module-name &/get-module-name
+ ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))]
? (&&module/defined? module-name ?name)]
(if ?
(fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
@@ -416,15 +417,20 @@
(return (&/|list)))
_
- (do (println 'DEF (str module-name ";" ?name))
+ (do ;; (println 'DEF (str module-name ";" ?name))
(|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
- :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]]
+ :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name))
+ _ (println 'DEF (str module-name ";" ?name))]]
(return (&/|list)))))
))))
(defn analyse-declare-macro [analyse compile-token ?name]
- (|do [module-name &/get-module-name
- _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))]
+ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")]
+ module-name &/get-module-name
+ ;; :let [_ (prn 'analyse-declare-macro ?name "1")]
+ _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))
+ ;; :let [_ (prn 'analyse-declare-macro ?name "2")]
+ ]
(return (&/|list))))
(defn ensure-undeclared-tags [module tags]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index e39f76409..44875d1df 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -58,7 +58,8 @@
"VarT"
"ExT"
"AllT"
- "AppT")
+ "AppT"
+ "NamedT")
;; [Fields]
;; Binding
@@ -229,7 +230,7 @@
(defn |head [xs]
(|case xs
($Nil)
- (assert false)
+ (assert false (prn-str '|head))
($Cons x _)
x))
@@ -237,7 +238,7 @@
(defn |tail [xs]
(|case xs
($Nil)
- (assert false)
+ (assert false (prn-str '|tail))
($Cons _ xs*)
xs*))
@@ -787,9 +788,8 @@
($Meta _ ($FormS ?elems))
(str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
- ;; _
- ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
- ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
+ _
+ (assert false (prn-str 'show-ast (adt->text ast)))
))
(defn ident->text [ident]
@@ -898,19 +898,6 @@
(and (= xmodule ymodule)
(= xname yname))))
-;; (defn |list-put [idx val xs]
-;; (|case [idx xs]
-;; [_ ($Nil)]
-;; (V $None nil)
-
-;; [0 ($Cons x xs*)]
-;; (V $Some (V $Cons (T val xs*)))
-
-;; [_ ($Cons x xs*)]
-;; (|case (|list-put idx val xs*)
-;; ($None) (V $None nil)
-;; ($Some xs**) (V $Some (V $Cons (T x xs**))))))
-
(defn |list-put [idx val xs]
(|case xs
($Nil)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 2516fbc1d..e78b5616a 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -26,14 +26,6 @@
_
false))
-(def Bool (&/V &/$DataT "java.lang.Boolean"))
-(def Int (&/V &/$DataT "java.lang.Long"))
-(def Real (&/V &/$DataT "java.lang.Double"))
-(def Char (&/V &/$DataT "java.lang.Character"))
-(def Text (&/V &/$DataT "java.lang.String"))
-(def Unit (&/V &/$TupleT (&/|list)))
-(def $Void (&/V &/$VariantT (&/|list)))
-
(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil)))
(def ^:private no-env (&/V &/$None nil))
(defn Data$ [name]
@@ -46,154 +38,174 @@
(&/V &/$LambdaT (&/T in out)))
(defn App$ [fun arg]
(&/V &/$AppT (&/T fun arg)))
-
(defn Tuple$ [members]
;; (assert (|list? members))
(&/V &/$TupleT members))
-
(defn Variant$ [members]
;; (assert (|list? members))
(&/V &/$VariantT members))
-
(defn All$ [env name arg body]
(&/V &/$AllT (&/T env name arg body)))
+(defn Named$ [name type]
+ (&/V &/$NamedT (&/T name type)))
+
+
+(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean")))
+(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long")))
+(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double")))
+(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character")))
+(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String")))
+(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list))))
+(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list))))
+(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text))))
(def IO
- (All$ empty-env "IO" "a"
- (Lambda$ Unit (Bound$ "a"))))
+ (Named$ (&/T "lux/data" "IO")
+ (All$ empty-env "IO" "a"
+ (Lambda$ Unit (Bound$ "a")))))
(def List
- (All$ empty-env "lux;List" "a"
- (Variant$ (&/|list
- ;; lux;Nil
- Unit
- ;; lux;Cons
- (Tuple$ (&/|list (Bound$ "a")
- (App$ (Bound$ "lux;List")
- (Bound$ "a"))))
- ))))
+ (Named$ (&/T "lux" "List")
+ (All$ empty-env "lux;List" "a"
+ (Variant$ (&/|list
+ ;; lux;Nil
+ Unit
+ ;; lux;Cons
+ (Tuple$ (&/|list (Bound$ "a")
+ (App$ (Bound$ "lux;List")
+ (Bound$ "a"))))
+ )))))
(def Maybe
- (All$ empty-env "lux;Maybe" "a"
- (Variant$ (&/|list
- ;; lux;None
- Unit
- ;; lux;Some
- (Bound$ "a")
- ))))
+ (Named$ (&/T "lux" "Maybe")
+ (All$ empty-env "lux;Maybe" "a"
+ (Variant$ (&/|list
+ ;; lux;None
+ Unit
+ ;; lux;Some
+ (Bound$ "a")
+ )))))
(def Type
- (let [Type (App$ (Bound$ "Type") (Bound$ "_"))
- TypeList (App$ List Type)
- TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
- TypePair (Tuple$ (&/|list Type Type))]
- (App$ (All$ empty-env "Type" "_"
- (Variant$ (&/|list
- ;; DataT
- Text
- ;; VariantT
- TypeList
- ;; TupleT
- TypeList
- ;; LambdaT
- TypePair
- ;; BoundT
- Text
- ;; VarT
- Int
- ;; ExT
- Int
- ;; AllT
- (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type))
- ;; AppT
- TypePair
- )))
- $Void)))
+ (Named$ (&/T "lux" "Type")
+ (let [Type (App$ (Bound$ "Type") (Bound$ "_"))
+ TypeList (App$ List Type)
+ TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
+ TypePair (Tuple$ (&/|list Type Type))]
+ (App$ (All$ empty-env "Type" "_"
+ (Variant$ (&/|list
+ ;; DataT
+ Text
+ ;; VariantT
+ TypeList
+ ;; TupleT
+ TypeList
+ ;; LambdaT
+ TypePair
+ ;; BoundT
+ Text
+ ;; VarT
+ Int
+ ;; ExT
+ Int
+ ;; AllT
+ (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type))
+ ;; AppT
+ TypePair
+ ;; NamedT
+ (Tuple$ (&/|list Ident Type))
+ )))
+ $Void))))
(def Bindings
- (All$ empty-env "lux;Bindings" "k"
- (All$ no-env "" "v"
- (Tuple$ (&/|list
- ;; "lux;counter"
- Int
- ;; "lux;mappings"
- (App$ List
- (Tuple$ (&/|list (Bound$ "k")
- (Bound$ "v")))))))))
+ (Named$ (&/T "lux" "Bindings")
+ (All$ empty-env "lux;Bindings" "k"
+ (All$ no-env "" "v"
+ (Tuple$ (&/|list
+ ;; "lux;counter"
+ Int
+ ;; "lux;mappings"
+ (App$ List
+ (Tuple$ (&/|list (Bound$ "k")
+ (Bound$ "v"))))))))))
(def Env
- (let [bindings (App$ (App$ Bindings (Bound$ "k"))
- (Bound$ "v"))]
- (All$ empty-env "lux;Env" "k"
- (All$ no-env "" "v"
- (Tuple$
- (&/|list
- ;; "lux;name"
- Text
- ;; "lux;inner-closures"
- Int
- ;; "lux;locals"
- bindings
- ;; "lux;closure"
- bindings
- ))))))
+ (Named$ (&/T "lux" "Env")
+ (let [bindings (App$ (App$ Bindings (Bound$ "k"))
+ (Bound$ "v"))]
+ (All$ empty-env "lux;Env" "k"
+ (All$ no-env "" "v"
+ (Tuple$
+ (&/|list
+ ;; "lux;name"
+ Text
+ ;; "lux;inner-closures"
+ Int
+ ;; "lux;locals"
+ bindings
+ ;; "lux;closure"
+ bindings
+ )))))))
(def Cursor
- (Tuple$ (&/|list Text Int Int)))
+ (Named$ (&/T "lux" "Cursor")
+ (Tuple$ (&/|list Text Int Int))))
(def Meta
- (All$ empty-env "lux;Meta" "m"
- (All$ no-env "" "v"
- (Variant$ (&/|list
- ;; &/$Meta
- (Tuple$ (&/|list (Bound$ "m")
- (Bound$ "v"))))))))
-
-(def Ident (Tuple$ (&/|list Text Text)))
+ (Named$ (&/T "lux" "Meta")
+ (All$ empty-env "lux;Meta" "m"
+ (All$ no-env "" "v"
+ (Variant$ (&/|list
+ ;; &/$Meta
+ (Tuple$ (&/|list (Bound$ "m")
+ (Bound$ "v")))))))))
(def AST*
- (let [AST* (App$ (Bound$ "w")
- (App$ (Bound$ "lux;AST'")
- (Bound$ "w")))
- AST*List (App$ List AST*)]
- (All$ empty-env "lux;AST'" "w"
- (Variant$ (&/|list
- ;; &/$BoolS
- Bool
- ;; &/$IntS
- Int
- ;; &/$RealS
- Real
- ;; &/$CharS
- Char
- ;; &/$TextS
- Text
- ;; &/$SymbolS
- Ident
- ;; &/$TagS
- Ident
- ;; &/$FormS
- AST*List
- ;; &/$TupleS
- AST*List
- ;; &/$RecordS
- (App$ List (Tuple$ (&/|list AST* AST*))))
- ))))
+ (Named$ (&/T "lux" "AST'")
+ (let [AST* (App$ (Bound$ "w")
+ (App$ (Bound$ "lux;AST'")
+ (Bound$ "w")))
+ AST*List (App$ List AST*)]
+ (All$ empty-env "lux;AST'" "w"
+ (Variant$ (&/|list
+ ;; &/$BoolS
+ Bool
+ ;; &/$IntS
+ Int
+ ;; &/$RealS
+ Real
+ ;; &/$CharS
+ Char
+ ;; &/$TextS
+ Text
+ ;; &/$SymbolS
+ Ident
+ ;; &/$TagS
+ Ident
+ ;; &/$FormS
+ AST*List
+ ;; &/$TupleS
+ AST*List
+ ;; &/$RecordS
+ (App$ List (Tuple$ (&/|list AST* AST*))))
+ )))))
(def AST
- (let [w (App$ Meta Cursor)]
- (App$ w (App$ AST* w))))
+ (Named$ (&/T "lux" "AST")
+ (let [w (App$ Meta Cursor)]
+ (App$ w (App$ AST* w)))))
(def ^:private ASTList (App$ List AST))
(def Either
- (All$ empty-env "lux;Either" "l"
- (All$ no-env "" "r"
- (Variant$ (&/|list
- ;; &/$Left
- (Bound$ "l")
- ;; &/$Right
- (Bound$ "r"))))))
+ (Named$ (&/T "lux" "Either")
+ (All$ empty-env "lux;Either" "l"
+ (All$ no-env "" "r"
+ (Variant$ (&/|list
+ ;; &/$Left
+ (Bound$ "l")
+ ;; &/$Right
+ (Bound$ "r")))))))
(def StateE
(All$ empty-env "lux;StateE" "s"
@@ -204,19 +216,21 @@
(Bound$ "a"))))))))
(def Source
- (App$ List
- (App$ (App$ Meta Cursor)
- Text)))
+ (Named$ (&/T "lux" "Source")
+ (App$ List
+ (App$ (App$ Meta Cursor)
+ Text))))
(def Host
- (Tuple$
- (&/|list
- ;; "lux;writer"
- (Data$ "org.objectweb.asm.ClassWriter")
- ;; "lux;loader"
- (Data$ "java.lang.ClassLoader")
- ;; "lux;classes"
- (Data$ "clojure.lang.Atom"))))
+ (Named$ (&/T "lux" "Host")
+ (Tuple$
+ (&/|list
+ ;; "lux;writer"
+ (Data$ "org.objectweb.asm.ClassWriter")
+ ;; "lux;loader"
+ (Data$ "java.lang.ClassLoader")
+ ;; "lux;classes"
+ (Data$ "clojure.lang.Atom")))))
(def DefData*
(All$ empty-env "lux;DefData'" ""
@@ -232,11 +246,12 @@
))))
(def LuxVar
- (Variant$ (&/|list
- ;; "lux;Local"
- Int
- ;; "lux;Global"
- Ident)))
+ (Named$ (&/T "lux" "LuxVar")
+ (Variant$ (&/|list
+ ;; "lux;Local"
+ Int
+ ;; "lux;Global"
+ Ident))))
(def $Module
(All$ empty-env "lux;$Module" "Compiler"
@@ -264,37 +279,39 @@
))))
(def $Compiler
- (App$ (All$ empty-env "lux;Compiler" ""
- (Tuple$
- (&/|list
- ;; "lux;source"
- Source
- ;; "lux;cursor"
- Cursor
- ;; "lux;modules"
- (App$ List (Tuple$ (&/|list Text
- (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))))
- ;; "lux;envs"
- (App$ List
- (App$ (App$ Env Text)
- (Tuple$ (&/|list LuxVar Type))))
- ;; "lux;types"
- (App$ (App$ Bindings Int) Type)
- ;; "lux;expected"
- Type
- ;; "lux;seed"
- Int
- ;; "lux;eval?"
- Bool
- ;; "lux;host"
- Host
- )))
- $Void))
+ (Named$ (&/T "lux" "Compiler")
+ (App$ (All$ empty-env "lux;Compiler" ""
+ (Tuple$
+ (&/|list
+ ;; "lux;source"
+ Source
+ ;; "lux;cursor"
+ Cursor
+ ;; "lux;modules"
+ (App$ List (Tuple$ (&/|list Text
+ (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))))
+ ;; "lux;envs"
+ (App$ List
+ (App$ (App$ Env Text)
+ (Tuple$ (&/|list LuxVar Type))))
+ ;; "lux;types"
+ (App$ (App$ Bindings Int) Type)
+ ;; "lux;expected"
+ Type
+ ;; "lux;seed"
+ Int
+ ;; "lux;eval?"
+ Bool
+ ;; "lux;host"
+ Host
+ )))
+ $Void)))
(def Macro
- (Lambda$ ASTList
- (App$ (App$ StateE $Compiler)
- ASTList)))
+ (Named$ (&/T "lux" "Macro")
+ (Lambda$ ASTList
+ (App$ (App$ StateE $Compiler)
+ ASTList))))
(defn bound? [id]
(fn [state]
@@ -512,8 +529,11 @@
(str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
?name)
+ (&/$NamedT ?name ?type)
+ (&/ident->text ?name)
+
_
- (assert false (prn-str 'show-type (aget type 0)))))
+ (assert false (prn-str 'show-type (&/adt->text type)))))
(defn type= [x y]
(or (clojure.lang.Util/identical x y)
@@ -566,6 +586,12 @@
(type= xbody ybody)
)
+ [(&/$NamedT ?xname ?xtype) _]
+ (type= ?xtype y)
+
+ [_ (&/$NamedT ?yname ?ytype)]
+ (type= x ?ytype)
+
[_ _]
false
)]
@@ -640,9 +666,12 @@
(&/$AppT F A)
(|do [type-fn* (apply-type F A)]
(apply-type type-fn* param))
+
+ (&/$NamedT ?name ?type)
+ (apply-type ?type param)
_
- (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n"))))
+ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n"))))
(defn as-obj [class]
(case class
@@ -805,7 +834,7 @@
(show-type a)))))
(&/|interpose "\n\n")
(&/fold str "")))
- (assert false))]
+ (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))]
(|case (fp-get fp-pair fixpoints)
(&/$Some ?)
(if ?
@@ -870,6 +899,12 @@
(return (&/T fixpoints nil))
(fail (check-error expected actual)))
+ [(&/$NamedT ?ename ?etype) _]
+ (check* class-loader fixpoints ?etype actual)
+
+ [_ (&/$NamedT ?aname ?atype)]
+ (check* class-loader fixpoints expected ?atype)
+
[_ _]
(fail (check-error expected actual))
)))
@@ -892,11 +927,15 @@
=return (apply-lambda func* param)]
(clean $var =return))))
+ (&/$NamedT ?name ?type)
+ (apply-lambda ?type param)
+
_
(fail (str "[Type System] Not a function type:\n" (show-type func) "\n"))
))
(defn actual-type [type]
+ "(-> Type (Lux Type))"
(|case type
(&/$AppT ?all ?param)
(|do [type* (apply-type ?all ?param)]
@@ -904,6 +943,9 @@
(&/$VarT ?id)
(deref ?id)
+
+ (&/$NamedT ?name ?type)
+ (actual-type ?type)
_
(return type)
@@ -911,6 +953,9 @@
(defn variant-case [tag type]
(|case type
+ (&/$NamedT ?name ?type)
+ (variant-case tag ?type)
+
(&/$VariantT ?cases)
(|case (&/|at tag ?cases)
(&/$Some case-type)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 04:40:46 +0000