From eb424eeb33d8fc9bb7ad2acda0c58fcb037717d3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 14 Jul 2015 22:47:10 -0400 Subject: - Added a ' (quote) macro that works like ` (backquote), without unquote or unquote splice working and not automatic prefixing of unprefixed symbols/tags. - Added (slightly) better type-error messages. --- input/lux.lux | 88 +++++++++++++++++++++++------------------- src/lux/analyser/case.clj | 2 +- src/lux/type.clj | 97 +++++++++++++++++++++++++++++++++++++++++------ 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) -- cgit v1.2.3