aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--input/lux.lux88
-rw-r--r--src/lux/analyser/case.clj2
-rw-r--r--src/lux/type.clj97
3 files changed, 137 insertions, 50 deletions
diff --git a/input/lux.lux b/input/lux.lux
index de407bafe..2bad33439 100644
--- a/input/lux.lux
+++ b/input/lux.lux
@@ -791,48 +791,52 @@
_
(fail "Wrong syntax for $")))
-(def'' (splice untemplate tag elems)
- (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
- (_lux_case (any? spliced? elems)
+(def'' (splice replace? untemplate tag elems)
+ (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
+ (_lux_case replace?
true
- (let [elems' (map (lambda [elem]
- (_lux_case elem
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
- spliced
-
- _
- (form$ (list (symbol$ ["" "_lux_:"])
- (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
- (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
- (tag$ ["lux" "Nil"])))))))))
- elems)]
- (wrap-meta (form$ (list tag
- (form$ (list& (symbol$ ["lux" "$"])
- (symbol$ ["lux" "list:++"])
- elems'))))))
-
+ (_lux_case (any? spliced? elems)
+ true
+ (let [elems' (map (lambda [elem]
+ (_lux_case elem
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
+ spliced
+
+ _
+ (form$ (list (symbol$ ["" "_lux_:"])
+ (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
+ (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
+ (tag$ ["lux" "Nil"])))))))))
+ elems)]
+ (wrap-meta (form$ (list tag
+ (form$ (list& (symbol$ ["lux" "$"])
+ (symbol$ ["lux" "list:++"])
+ elems'))))))
+
+ false
+ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))
false
(wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
-(def'' (untemplate subst token)
- (->' Text Syntax Syntax)
- (_lux_case token
- (#Meta [_ (#BoolS value)])
+(def'' (untemplate replace? subst token)
+ (->' Bool Text Syntax Syntax)
+ (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token])
+ [_ (#Meta [_ (#BoolS value)])]
(wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))
- (#Meta [_ (#IntS value)])
+ [_ (#Meta [_ (#IntS value)])]
(wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))
- (#Meta [_ (#RealS value)])
+ [_ (#Meta [_ (#RealS value)])]
(wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))
- (#Meta [_ (#CharS value)])
+ [_ (#Meta [_ (#CharS value)])]
(wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))
- (#Meta [_ (#TextS value)])
+ [_ (#Meta [_ (#TextS value)])]
(wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))
- (#Meta [_ (#TagS [module name])])
+ [_ (#Meta [_ (#TagS [module name])])]
(let [module' (_lux_case module
""
subst
@@ -841,7 +845,7 @@
module)]
(wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))
- (#Meta [_ (#SymbolS [module name])])
+ [_ (#Meta [_ (#SymbolS [module name])])]
(let [module' (_lux_case module
""
subst
@@ -850,32 +854,40 @@
module)]
(wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name)))))))
- (#Meta [_ (#TupleS elems)])
- (splice (untemplate subst) (tag$ ["lux" "TupleS"]) elems)
+ [_ (#Meta [_ (#TupleS elems)])]
+ (splice (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])
+ [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])]
unquoted
- (#Meta [_ (#FormS elems)])
- (splice (untemplate subst) (tag$ ["lux" "FormS"]) elems)
+ [_ (#Meta [_ (#FormS elems)])]
+ (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)
- (#Meta [_ (#RecordS fields)])
+ [_ (#Meta [_ (#RecordS fields)])]
(wrap-meta (form$ (list (tag$ ["lux" "RecordS"])
(untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax)
(lambda [kv]
(let [[k v] kv]
- (tuple$ (list (untemplate subst k) (untemplate subst v))))))
+ (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v))))))
fields)))))
))
(defmacro (`' tokens)
(_lux_case tokens
(#Cons [template #Nil])
- (return (list (untemplate "" template)))
+ (return (list (untemplate true "" template)))
_
(fail "Wrong syntax for `'")))
+(defmacro (' tokens)
+ (_lux_case tokens
+ (#Cons [template #Nil])
+ (return (list (untemplate false "" template)))
+
+ _
+ (fail "Wrong syntax for '")))
+
(defmacro #export (|> tokens)
(_lux_case tokens
(#Cons [init apps])
@@ -1648,7 +1660,7 @@
[module-name get-module-name]
(case tokens
(\ (list template))
- (;return (list (untemplate module-name template)))
+ (;return (list (untemplate true module-name template)))
_
(fail "Wrong syntax for `"))))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 6efe7fd5f..6dfa234bd 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -77,7 +77,7 @@
(return (&/T (&/V "TupleTestAC" =tests) =kont))))
[_]
- (fail "[Analyser Error] Tuples require tuple-type."))
+ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type value-type))))
[["lux;RecordS" ?slots]]
(|do [value-type* (resolve-type value-type)]
diff --git a/src/lux/type.clj b/src/lux/type.clj
index e7d6353e8..c3a27ce2b 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -338,6 +338,15 @@
[_]
(fail (str "[Type Error] Not type-var: " (show-type tvar)))))
+(defn ^:private unravel-app [fun-type]
+ (matchv ::M/objects [fun-type]
+ [["lux;AppT" [?left ?right]]]
+ (|let [[?fun-type ?args] (unravel-app ?left)]
+ (&/T ?fun-type (&/|++ ?args (&/|list ?right))))
+
+ [_]
+ (&/T fun-type (&/|list))))
+
(defn show-type [^objects type]
(matchv ::M/objects [type]
[["lux;DataT" name]]
@@ -384,23 +393,89 @@
[["lux;ExT" ?id]]
(str "⟨" ?id "⟩")
- [["lux;AppT" [?lambda ?param]]]
- (str "(" (show-type ?lambda) " " (show-type ?param) ")")
+ [["lux;AppT" [_ _]]]
+ (|let [[?call-fun ?call-args] (unravel-app type)]
+ (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
[["lux;AllT" [?env ?name ?arg ?body]]]
- (let [[args body] (loop [args (list ?arg)
- body* ?body]
- (matchv ::M/objects [body*]
- [["lux;AllT" [?env* ?name* ?arg* ?body*]]]
- (recur (cons ?arg* args) ?body*)
-
- [_]
- [args body*]))]
- (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
+ (if (= "" ?name)
+ (let [[args body] (loop [args (list ?arg)
+ body* ?body]
+ (matchv ::M/objects [body*]
+ [["lux;AllT" [?env* ?name* ?arg* ?body*]]]
+ (recur (cons ?arg* args) ?body*)
+
+ [_]
+ [args body*]))]
+ (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
+ ?name)
[_]
(assert false (prn-str 'show-type (aget type 0) (class (aget type 1))))
))
+;; (defn show-type [^objects type]
+;; (matchv ::M/objects [type]
+;; [["lux;DataT" name]]
+;; (str "(^ " name ")")
+
+;; [["lux;TupleT" elems]]
+;; (if (&/|empty? elems)
+;; "(,)"
+;; (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
+
+;; [["lux;VariantT" cases]]
+;; (if (&/|empty? cases)
+;; "(|)"
+;; (str "(| " (->> cases
+;; (&/|map (fn [kv]
+;; (matchv ::M/objects [kv]
+;; [[k ["lux;TupleT" ["lux;Nil" _]]]]
+;; (str "#" k)
+
+;; [[k v]]
+;; (str "(#" k " " (show-type v) ")"))))
+;; (&/|interpose " ")
+;; (&/fold str "")) ")"))
+
+
+;; [["lux;RecordT" fields]]
+;; (str "(& " (->> fields
+;; (&/|map (fn [kv]
+;; (matchv ::M/objects [kv]
+;; [[k v]]
+;; (str "#" k " " (show-type v)))))
+;; (&/|interpose " ")
+;; (&/fold str "")) ")")
+
+;; [["lux;LambdaT" [input output]]]
+;; (str "(-> " (show-type input) " " (show-type output) ")")
+
+;; [["lux;VarT" id]]
+;; (str "⌈" id "⌋")
+
+;; [["lux;BoundT" name]]
+;; name
+
+;; [["lux;ExT" ?id]]
+;; (str "⟨" ?id "⟩")
+
+;; [["lux;AppT" [?lambda ?param]]]
+;; (str "(" (show-type ?lambda) " " (show-type ?param) ")")
+
+;; [["lux;AllT" [?env ?name ?arg ?body]]]
+;; (let [[args body] (loop [args (list ?arg)
+;; body* ?body]
+;; (matchv ::M/objects [body*]
+;; [["lux;AllT" [?env* ?name* ?arg* ?body*]]]
+;; (recur (cons ?arg* args) ?body*)
+
+;; [_]
+;; [args body*]))]
+;; (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
+
+;; [_]
+;; (assert false (prn-str 'show-type (aget type 0) (class (aget type 1))))
+;; ))
(defn type= [x y]
(or (clojure.lang.Util/identical x y)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 23:42:58 +0000