diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lux.clj | 1 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 28 | ||||
| -rw-r--r-- | src/lux/analyser/def.clj | 28 | ||||
| -rw-r--r-- | src/lux/analyser/env.clj | 47 | ||||
| -rw-r--r-- | src/lux/analyser/lambda.clj | 9 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 35 | ||||
| -rw-r--r-- | src/lux/base.clj | 443 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 36 | ||||
| -rw-r--r-- | src/lux/lexer.clj | 115 | ||||
| -rw-r--r-- | src/lux/macro.clj | 16 | ||||
| -rw-r--r-- | src/lux/parser.clj | 69 | ||||
| -rw-r--r-- | src/lux/type.clj | 194 |
12 files changed, 563 insertions, 458 deletions
diff --git a/src/lux.clj b/src/lux.clj index c7b000e5b..3516f2a9c 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -7,6 +7,7 @@ ;; TODO: Re-implement compiler in language. ;; TODO: Adding metadata to global vars. ;; TODO: Add column & line numbers for syntactic elements. + ;; TODO: Add text-dispenser to regulate column & line numbering. ;; TODO: Add source-file information to .class files for easier debugging. ;; TODO: Finish implementing class & interface definition ;; TODO: All optimizations diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 123783daa..2c45c160a 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,6 +1,6 @@ (ns lux.analyser (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + [clojure.core.match :as M :refer [matchv]] clojure.core.match.array (lux [base :as & :refer [exec return fail |list @@ -34,19 +34,19 @@ (matchv ::M/objects [token] ;; Standard special forms [["Bool" ?value]] - (return (|list [::&&/Expression [::&&/bool ?value] (&/V "Data" (to-array ["java.lang.Boolean" (&/V "Nil" nil)]))])) + (return (|list [::&&/Expression [::&&/bool ?value] (&/V "Data" (&/T "java.lang.Boolean" (&/V "Nil" nil)))])) [["Int" ?value]] - (return (|list [::&&/Expression [::&&/int ?value] (&/V "Data" (to-array ["java.lang.Long" (&/V "Nil" nil)]))])) + (return (|list [::&&/Expression [::&&/int ?value] (&/V "Data" (&/T "java.lang.Long" (&/V "Nil" nil)))])) [["Real" ?value]] - (return (|list [::&&/Expression [::&&/real ?value] (&/V "Data" (to-array ["java.lang.Double" (&/V "Nil" nil)]))])) + (return (|list [::&&/Expression [::&&/real ?value] (&/V "Data" (&/T "java.lang.Double" (&/V "Nil" nil)))])) [["Char" ?value]] - (return (|list [::&&/Expression [::&&/char ?value] (&/V "Data" (to-array ["java.lang.Character" (&/V "Nil" nil)]))])) + (return (|list [::&&/Expression [::&&/char ?value] (&/V "Data" (&/T "java.lang.Character" (&/V "Nil" nil)))])) [["Text" ?value]] - (return (|list [::&&/Expression [::&&/text ?value] (&/V "Data" (to-array ["java.lang.String" (&/V "Nil" nil)]))])) + (return (|list [::&&/Expression [::&&/text ?value] (&/V "Data" (&/T "java.lang.String" (&/V "Nil" nil)))])) [["Tuple" ?elems]] (&&lux/analyse-tuple analyse ?elems) @@ -56,18 +56,18 @@ [["Tag" ?tag]] (let [tuple-type (&/V "Tuple" (&/V "Nil" nil))] - (return (|list [::&&/Expression [::&&/variant ?tag [::&&/Expression [::&&/tuple (list)] tuple-type]] - (&/V "Variant" (&/V "Cons" (to-array [(to-array [?tag tuple-type]) (&/V "Nil" nil)])))]))) + (return (|list [::&&/Expression [::&&/variant ?tag [::&&/Expression [::&&/tuple (|list)] tuple-type]] + (&/V "Variant" (&/V "Cons" (&/T (&/T ?tag tuple-type) (&/V "Nil" nil))))]))) [["Ident" "jvm-null"]] - (return (|list [::&&/Expression [::&&/jvm-null] (&/V "Data" (to-array ["null" (&/V "Nil" nil)]))])) + (return (|list [::&&/Expression [::&&/jvm-null] (&/V "Data" (&/T "null" (&/V "Nil" nil)))])) [["Ident" ?ident]] (&&lux/analyse-ident analyse ?ident) [["Form" ["Cons" [["Ident" "case'"] ["Cons" [?variant ?branches]]]]]] - (&&lux/analyse-case analyse ?variant (&/->seq ?branches)) + (&&lux/analyse-case analyse ?variant ?branches) [["Form" ["Cons" [["Ident" "lambda'"] ["Cons" [["Ident" ?self] @@ -403,15 +403,15 @@ ;; :let [_ (prn 'POST-ASSERT)] =value (&&/analyse-1 (analyse-ast eval!) (first ?values)) =value-type (&&/expr-type =value)] - (return (|list [::&&/Expression [::&&/variant ?tag =value] (&/V "Variant" (&/V "Cons" (to-array [(to-array [?tag =value-type]) (&/V "Nil" nil)])))]))) + (return (|list [::&&/Expression [::&&/variant ?tag =value] (&/V "Variant" (&/V "Cons" (&/T (&/T ?tag =value-type) (&/V "Nil" nil))))]))) [["Form" ["Cons" [?fn ?args]]]] (fn [state] - (match ((&&/analyse-1 (analyse-ast eval!) ?fn) state) - [::&/ok [state* =fn]] + (matchv ::M/objects [((&&/analyse-1 (analyse-ast eval!) ?fn) state)] + [["Right" [state* =fn]]] ((&&lux/analyse-apply (analyse-ast eval!) =fn ?args) state*) - _ + [_] ((analyse-basic-ast (analyse-ast eval!) eval! token) state))) [_] diff --git a/src/lux/analyser/def.clj b/src/lux/analyser/def.clj index c6443ca22..c7454351b 100644 --- a/src/lux/analyser/def.clj +++ b/src/lux/analyser/def.clj @@ -1,35 +1,37 @@ (ns lux.analyser.def (:require (clojure [template :refer [do-template]]) - [clojure.core.match :refer [match]] - (lux [base :as & :refer [exec return fail + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [exec return return* fail if-m try-all-m map-m mapcat-m reduce-m assert!]]) [lux.analyser.base :as &&])) ;; [Exports] (def init-module - {::defs {} - ::macros #{}}) + (R "defs" (|table) + "macros" (|table))) (do-template [<name> <category>] (defn <name> [module name] (fn [state] - [::&/ok [state (boolean (get-in state [::&/modules module <category> name]))]])) + (return* state + (->> state (get$ "modules") (|get module) (get$ <category>) (|get name) boolean)))) - defined? ::defs - macro? ::macros + defined? "defs" + macro? "macros" ) (defn declare-macro [module name] (fn [state] - [::&/ok [(update-in state [::&/modules module ::macros] conj name) - nil]])) + (return* (update$ "modules" (fn [ms] (|update module (fn [m] (update$ "macros" #(|put name true %) m)) ms)) state) + nil))) (defn define [module name type] (fn [state] (let [full-name (str module &/+name-separator+ name) bound [::&&/Expression [::&&/global module name] type]] - [::&/ok [(-> state - (assoc-in [::&/modules module ::defs name] type) - (update-in [::&/global-env] merge {full-name bound, name bound})) - nil]]))) + (return* (->> state + (update$ "modules" (fn [ms] (|update module (fn [m] (update$ "defs" #(|put name type %) m)) ms))) + (update$ "global-env" #(|merge (|table full-name bound, name bound) %))) + nil)))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 5b52e3db3..5d70434bb 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,6 +1,9 @@ (ns lux.analyser.env - (:require [clojure.core.match :refer [match]] - (lux [base :as & :refer [exec return fail + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [exec return return* fail + get$ set$ update$ + |list |get |contains? |concat if-m try-all-m map-m mapcat-m reduce-m assert!]]) [lux.analyser.base :as &&])) @@ -8,28 +11,30 @@ ;; [Exports] (def next-local-idx (fn [state] - [::&/ok [state (-> state ::&/local-envs first :locals :counter)]])) + (return* state (->> state (get$ "local-envs") |head (get$ "locals") (get$ "counter"))))) (defn with-local [name type body] (fn [state] - (let [old-mappings (-> state ::&/local-envs first (get-in [:locals :mappings])) - =return (body (update-in state [::&/local-envs] - (fn [[top & stack]] - (let [bound-unit [::&&/local (get-in top [:locals :counter])]] - (cons (-> top - (update-in [:locals :counter] inc) - (assoc-in [:locals :mappings name] [::&&/Expression bound-unit type])) - stack)))))] - (match =return - [::&/ok [?state ?value]] - [::&/ok [(update-in ?state [::&/local-envs] (fn [[top* & stack*]] - (cons (-> top* - (update-in [:locals :counter] dec) - (assoc-in [:locals :mappings] old-mappings)) - stack*))) - ?value]] + (let [old-mappings (->> state (get$ "local-envs") |head (get$ "locals") (get$ "mappings")) + =return (body (update$ "local-envs" + (fn [[top & stack]] + (let [bound-unit [::&&/local (-> top (get$ "locals") (get$ "counter"))]] + (cons (-> top + (update$ "locals" #(update$ "counter" inc %)) + (update$ "locals" #(update$ "mappings" (fn [m] (|put name [::&&/Expression bound-unit type] m)) %))) + stack))) + state))] + (matchv ::M/objects [=return] + [["Right" [?state ?value]]] + (return* (update$ "local-envs" (fn [[top* & stack*]] + (cons (->> top* + (update$ "locals" #(update$ "counter" dec %)) + (update$ "locals" #(set$ "mappings" old-mappings %))) + stack*)) + ?state) + ?value) - _ + [_] =return)))) (defn with-locals [locals monad] @@ -40,4 +45,4 @@ (def captured-vars (fn [state] - [::&/ok [state (-> state ::&/local-envs first :closure :mappings)]])) + (return* state (->> state (get$ "local-envs") |head (get$ "closure") (get$ "mappings"))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 61daa5e5f..f231b744a 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -19,7 +19,8 @@ (defn close-over [scope ident register frame] (match register [::&&/Expression _ register-type] - (let [register* [::&&/Expression [::&&/captured scope (get-in frame [:closure :counter]) register] register-type]] - [register* (update-in frame [:closure] #(-> % - (update-in [:counter] inc) - (assoc-in [:mappings ident] register*)))]))) + (let [register* [::&&/Expression [::&&/captured scope (->> frame (get$ "closure") (get$ "counter")) register] register-type]] + [register* (update$ "closure" #(-> % + (update$ "counter" inc) + (update$ "mappings" #(|put ident register* %))) + frame)]))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index f3d00015d..f060b68c4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -1,9 +1,10 @@ (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [exec return fail - |list + (lux [base :as & :refer [exec return return* fail fail* + get$ set$ update$ + |list |get |contains? |concat if-m try-all-m |map% |flat-map% |fold% map-m mapcat-m reduce-m assert!]] [parser :as &parser] @@ -44,29 +45,29 @@ (defn analyse-ident [analyse ident] (exec [module-name &/get-module-name] (fn [state] - (let [[top & stack*] (::&/local-envs state)] - (if-let [=bound (or (get-in top [:locals :mappings ident]) - (get-in top [:closure :mappings ident]))] - [::&/ok [state (|list =bound)]] - (let [no-binding? #(and (-> % :locals :mappings (contains? ident) not) - (-> % :closure :mappings (contains? ident) not)) + (let [[top & stack*] (get$ "local-envs" state)] + (if-let [=bound (or (->> top (get$ "locals") (get$ "mappings") (|get ident)) + (->> top (get$ "closure") (get$ "mappings") (|get ident)))] + (return* state (|list =bound)) + (let [no-binding? #(and (->> % (get$ "locals") (get$ "mappings") (|contains? ident) not) + (->> % (get$ "closure") (get$ "mappings") (|contains? ident) not)) [inner outer] (split-with no-binding? stack*)] (if (empty? outer) - (if-let [global (get-in state [::&/global-env ident])] - [::&/ok [state (|list global)]] - [::&/failure (str "[Analyser Error] Unresolved identifier: " ident)]) + (if-let [global (->> state (get$ "global-env") (|get ident))] + (return* state (|list global)) + (fail* (str "[Analyser Error] Unresolved identifier: " ident))) (let [in-stack (cons top inner) - scopes (rest (reductions #(cons (:name %2) %1) (map :name outer) (reverse in-stack))) - _ (prn 'in-stack module-name ident (map :name in-stack) scopes) + scopes (rest (reductions #(cons (get$ "name" %2) %1) (map #(get$ "name" %) outer) (reverse in-stack))) + _ (prn 'in-stack module-name ident (map #(get$ "name" %) in-stack) scopes) [=local inner*] (reduce (fn [[register new-inner] [frame in-scope]] (let [[register* frame*] (&&lambda/close-over (cons module-name (reverse in-scope)) ident register frame)] [register* (cons frame* new-inner)])) - [(or (get-in (first outer) [:locals :mappings ident]) - (get-in (first outer) [:closure :mappings ident])) + [(or (->> outer |head (get$ "locals") (get$ "mappings") (|get ident)) + (->> outer |head (get$ "closure") (get$ "mappings") (|get ident))) '()] (map vector (reverse in-stack) scopes) )] - [::&/ok [(assoc state ::&/local-envs (concat inner* outer)) (|list =local)]]) + (return* (set$ "local-envs" (|concat inner* outer) state) (|list =local))) )) )) ))) diff --git a/src/lux/base.clj b/src/lux/base.clj index d2d06c6ea..d0b349eeb 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -1,36 +1,67 @@ (ns lux.base (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [Resources] -;; [Resources/Contants] +;; [Exports] (def +name-separator+ ";") -;; [Resources/Utils] +(defn T [& elems] + (to-array elems)) + +(defn V [tag value] + (to-array [tag value])) + +(defn R [& kvs] + (to-array kvs)) + +(defn get$ [slot record] + (let [size (alength record)] + (loop [idx 0] + (if (< idx size) + (if (= slot (aget record idx)) + (aget record (+ 1 idx)) + (recur (+ 2 idx))) + (assert false))))) + +(defn set$ [slot value record] + (let [record (aclone record) + size (alength record)] + (loop [idx 0] + (if (< idx size) + (if (= slot (aget record idx)) + (aset record (+ 1 idx) value) + (recur (+ 2 idx))) + (assert false))))) + +(defmacro update$ [slot f record] + `(let [record# ~record] + (set$ ~slot (~f (get$ ~slot record#)) + record#))) + (defn fail* [message] - [::failure message]) + (V "Left" message)) (defn return* [state value] - [::ok [state value]]) + (V "Right" (T state value))) ;; [Resources/Monads] (defn fail [message] (fn [_] - [::failure message])) + (V "Left" message))) (defn return [value] (fn [state] - [::ok [state value]])) + (V "Right" (T state value)))) (defn bind [m-value step] (fn [state] (let [inputs (m-value state)] - (match inputs - [::ok [?state ?datum]] + (matchv ::M/objects [inputs] + [["Right" [?state ?datum]]] ((step ?datum) ?state) - [::failure _] + [_] inputs)))) (defmacro exec [steps return] @@ -45,78 +76,127 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn try-m [monad] +(defn try% [monad] (fn [state] - (match (monad state) - [::ok [?state ?datum]] + (matchv ::M/objects [(monad state)] + [["Right" [?state ?datum]]] (return* ?state ?datum) - [::failure _] + [_] (return* state nil)))) -(defn repeat-m [monad] - (fn [state] - (match (monad state) - [::ok [?state ?head]] - (do ;; (prn 'repeat-m/?state ?state) - (match ((repeat-m monad) ?state) - [::ok [?state* ?tail]] - (do ;; (prn 'repeat-m/?state* ?state*) - (return* ?state* (cons ?head ?tail))))) - - [::failure ?message] - (do ;; (println "Failed at last:" ?message) - (return* state '()))))) +(defn |cons [head tail] + (V "Cons" (T head tail))) -(def source-consumed? - (fn [state] - [::ok [state (empty? (::source state))]])) +(defn |map [f xs] + (matchv ::M/objects [xs] + [["Nil" _]] + xs -(defn exhaust-m [monad] - (exec [output-h monad - ? source-consumed? - output-t (if ? - (return (list)) - (exhaust-m monad))] - (return (cons output-h output-t)))) + [["Cons" [x xs*]]] + (V "Cons" (T (f x) (|map f xs*))))) -(defn try-all-m [monads] - (if (empty? monads) - (fail "Can't try no alternatives!") - (fn [state] - (let [output ((first monads) state)] - (match output - [::ok _] - output - - _ - (if-let [monads* (seq (rest monads))] - ((try-all-m monads*) state) - output) - ))))) +(defn fold [f init xs] + (matchv ::M/objects [xs] + [["Nil" _]] + init + + [["Cons" [x xs*]]] + (fold f (f init x) xs*))) + +(defn |length [xs] + (fold (fn [acc _] (inc acc)) 0 xs)) -(defn if-m [text-m then-m else-m] +(defn zip2 [xs ys] + (matchv ::M/objects [xs ys] + [["Cons" [x xs*]] ["Cons" [y ys*]]] + (V "Cons" (T (T x y) (zip2 xs* ys*))) + + [_ _] + (V "Nil" nil))) + +(defn |keys [plist] + (matchv ::M/objects [plist] + [["Nil" _]] + (|list) + + [["Cons" [[k v] plist*]]] + (|cons k (|keys plist*)))) + +(defn |interpose [sep xs] + (matchv ::M/objects [xs] + [["Nil" _]] + xs + + [["Cons" [_ ["Nil" _]]]] + xs + + [["Cons" [x xs*]]] + (V "Cons" (T x (V "Cons" (T sep (|interpose sep xs*))))))) + +(let [cons% (fn [head tail] + (V "Cons" (T head tail))) + ++% (fn ++% [xs ys] + (matchv ::M/objects [xs] + [["Nil" _]] + ys + + [["Cons" [x xs*]]] + (V "Cons" (T x (++% xs* ys)))))] + (do-template [<name> <joiner>] + (defn <name> [f xs] + (matchv ::M/objects [xs] + [["Nil" _]] + (return xs) + + [["Cons" [x xs*]]] + (exec [y (f x) + ys (<name> f xs*)] + (return (<joiner> y ys))))) + + map% cons% + flat-map% ++%)) + +(defn fold% [f init xs] + (matchv ::M/objects [xs] + [["Nil" _]] + init + + [["Cons" [x xs*]]] + (fold% f (f init x) xs*))) + +(defn |get [record slot] + (matchv ::M/objects [record] + [["Nil" _]] + (V "Left" (str "Not found: " slot)) + + [["Cons" [[k v] record*]]] + (if (= k slot) + (V "Right" v) + (|get record* slot)))) + +(defmacro |list [& elems] + (reduce (fn [tail head] + `(V "Cons" (T ~head ~tail))) + `(V "Nil" nil) + elems)) + +(defn if% [text-m then-m else-m] (exec [? text-m] (if ? then-m else-m))) -(defn reduce-m [f init inputs] - (if (empty? inputs) - (return init) - (exec [init* (f init (first inputs))] - (reduce-m f init* (rest inputs))))) - -(defn apply-m [monad call-state] +(defn apply% [monad call-state] (fn [state] ;; (prn 'apply-m monad call-state) (let [output (monad call-state)] ;; (prn 'apply-m/output output) - (match output - [::ok [?state ?datum]] - [::ok [state ?datum]] + (matchv ::M/objects [output] + [["Right" [?state ?datum]]] + (return* state ?datum) - [::failure _] + [_] output)))) (defn assert! [test message] @@ -124,7 +204,7 @@ (return nil) (fail message))) -(defn comp-m [f-m g-m] +(defn comp% [f-m g-m] (exec [temp g-m] (f-m temp))) @@ -136,15 +216,61 @@ (fn [state] (return* state state))) -(defn sequence-m [m-values] - (match m-values - ([head & tail] :seq) +(defn sequence% [m-values] + (matchv ::M/objects [m-values] + [["Cons" [head tail]]] (exec [_ head] - (sequence-m tail)) + (sequence% tail)) - _ + [_] (return nil))) +(defn repeat% [monad] + (fn [state] + (matchv ::M/objects [(monad state)] + [["Right" [?state ?head]]] + (do ;; (prn 'repeat-m/?state ?state) + (matchv ::M/objects [((repeat% monad) ?state)] + [["Right" [?state* ?tail]]] + (do ;; (prn 'repeat-m/?state* ?state*) + (return* ?state* (|cons ?head ?tail))))) + + [["Left" ?message]] + (do ;; (println "Failed at last:" ?message) + (return* state (V "Nil" nil)))))) + +(def source-consumed? + (fn [state] + (return* state (empty? (get$ "source" state))))) + +(defn exhaust% [monad] + (exec [output-h monad + ? source-consumed? + output-t (if ? + (return (|list)) + (exhaust% monad))] + (return (|cons output-h output-t)))) + +(defn try-all% [monads] + (matchv ::M/objects [monads] + [["Nil" _]] + (fail "There are no alternatives to try!") + + [["Cons" [m monads*]]] + (fn [state] + (let [output (m state)] + (matchv ::M/objects [output monads*] + [["Right" _] _] + output + + [_ ["Nil" _]] + output + + [_ _] + ((try-all% monads*) state) + ))) + )) + (defn ^:private normalize-char [char] (case char \* "_ASTER_" @@ -164,7 +290,6 @@ \! "_BANG_" \? "_QM_" \: "_COLON_" - \; "_SCOLON_" \. "_PERIOD_" \, "_COMMA_" \< "_LT_" @@ -178,113 +303,100 @@ (def loader (fn [state] - (return* state (::loader state)))) + (return* state (get$ "loader" state)))) (def +init-bindings+ - {:counter 0 - :mappings {}}) + (R "counter" 0 + "mappings" (|list))) (defn env [name] - {:name name - :inner-closures 0 - :locals +init-bindings+ - :closure +init-bindings+}) + (R "name" name + "inner-closures" 0 + "locals" +init-bindings+ + "closure" +init-bindings+)) (defn init-state [] - {::source nil - ::modules {} - ::global-env nil - ::local-envs (list) - ::types +init-bindings+ - ::writer nil - ::loader (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) - ::eval-ctor 0}) + (R "source" (V "None" nil) + "modules" (|list) + "global-env" (V "None" nil) + "local-envs" (|list) + "types" +init-bindings+ + "writer" (V "None" nil) + "loader" (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) + "eval-ctor" 0)) (def get-eval-ctor (fn [state] - (return* (update-in state [::eval-ctor] inc) (::eval-ctor state)))) + (return* (update$ "eval-ctor" inc state) (get$ "eval-ctor" state)))) (def get-writer (fn [state] - (if-let [datum (::writer state)] - [::ok [state datum]] - [::failure "Writer hasn't been set."]))) + (matchv ::M/objects [(get$ "writer" state)] + [["Some" datum]] + (return* state datum) + + [_] + (fail* "Writer hasn't been set.")))) (def get-top-local-env (fn [state] - (if-let [datum (first (::local-envs state))] - [::ok [state datum]] - [::failure "Module hasn't been set."]))) + (return* state (|head (get$ "local-envs" state))))) (def get-current-module-env (fn [state] - (if-let [datum (::global-env state)] - [::ok [state datum]] - [::failure "Module hasn't been set."]))) + (matchv ::M/objects [(get$ "global-env" state)] + [["Some" datum]] + (return* state datum) + + [_] + (fail* "Module hasn't been set.")))) (def get-module-name (exec [module get-current-module-env] - (return (:name module)))) + (return (get$ "name" module)))) (defn ^:private with-scope [name body] (fn [state] - (let [output (body (update-in state [::local-envs] conj (env name)))] - (match output - [::ok [state* datum]] - [::ok [(update-in state* [::local-envs] rest) datum]] + (let [output (body (update$ "local-envs" #(conj % (env name)) state))] + (matchv ::M/objects [output] + [["Right" [state* datum]]] + (return* (update$ "local-envs" rest state*) datum) - _ + [_] output)))) (defn with-closure [body] - (exec [[local? closure-name] (try-all-m (list (exec [top get-top-local-env] - (return [true (-> top :inner-closures str)])) - (exec [global get-current-module-env] - (return [false (-> global :inner-closures str)]))))] + (exec [[local? closure-name] (try-all% (list (exec [top get-top-local-env] + (return [true (->> top (get$ "inner-closures") str)])) + (exec [global get-current-module-env] + (return [false (->> global (get$ "inner-closures") str)]))))] (fn [state] (let [body* (with-scope closure-name body)] (body* (if local? - (update-in state [::local-envs] - #(cons (update-in (first %) [:inner-closures] inc) - (rest %))) - (update-in state [::global-env :inner-closures] inc))))))) + (update$ "local-envs" #(cons (update$ "inner-closures" inc (first %)) + (rest %)) + state) + (update$ "global-env" #(update$ "inner-closures" inc %) state))))))) (def get-scope-name (exec [module-name get-module-name] (fn [state] - [::ok [state (->> state ::local-envs (map :name) reverse (cons module-name))]]))) + (return* state (->> state (get$ "local-envs") (map #(get$ "name" %)) reverse (cons module-name)))))) (defn with-writer [writer body] (fn [state] - (let [output (body (assoc state ::writer writer))] - (match output - [::ok [?state ?value]] - [::ok [(assoc ?state ::writer (::writer state)) ?value]] + (let [output (body (set$ "writer" writer state))] + (matchv ::M/objects [output] + [["Right" [?state ?value]]] + (return* (set$ "writer" (get$ "writer" state) ?state) ?value) - _ + [_] output)))) (defn run-state [monad state] (monad state)) -(defn T [& elems] - (to-array elems)) - -(defn V [tag value] - (to-array [tag value])) - -(defn R [& kvs] - (to-array (reduce concat '() kvs))) - -(defn ->seq [xs] - (matchv ::M/objects [xs] - [["Nil" _]] - (list) - - [["Cons" [x xs*]]] - (cons x (->seq xs*)))) - (defn show-ast [ast] (matchv ::M/objects [ast] [["Bool" ?value]] @@ -309,69 +421,8 @@ ?ident [["Tuple" ?elems]] - (str "[" (->> (->seq ?elems) (map show-ast) (interpose " ") (apply str)) "]") + (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") [["Form" ?elems]] - (str "(" (->> (->seq ?elems) (map show-ast) (interpose " ") (apply str)) ")") + (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) - -(defn |map [f xs] - (matchv ::M/objects [xs] - [["Nil" _]] - xs - - [["Cons" [x xs*]]] - (V "Cons" (to-array [(f x) (|map f xs*)])))) - -(defn |->list [seq] - (reduce (fn [tail head] - (V "Cons" (to-array [head tail]))) - (V "Nil" nil) - seq)) - -(let [cons% (fn [head tail] - (V "Cons" (to-array [head tail]))) - ++% (fn ++% [xs ys] - (matchv ::M/objects [xs] - [["Nil" _]] - ys - - [["Cons" [x xs*]]] - (V "Cons" (to-array [x (++% xs* ys)]))))] - (do-template [<name> <joiner>] - (defn <name> [f xs] - (matchv ::M/objects [xs] - [["Nil" _]] - (return xs) - - [["Cons" [x xs*]]] - (exec [y (f x) - ys (<name> f xs*)] - (return (<joiner> y ys))))) - - |map% cons% - |flat-map% ++%)) - -(defn |fold% [f init xs] - (matchv ::M/objects [xs] - [["Nil" _]] - init - - [["Cons" [x xs*]]] - (|fold% f (f init x) xs*))) - -(defn |get [record slot] - (matchv ::M/objects [record] - [["Nil" _]] - (V "Error" (str "Not found: " slot)) - - [["Cons" [[k v] record*]]] - (if (= k slot) - (V "Ok" v) - (|get record* slot)))) - -(defmacro |list [elems] - (reduce (fn [tail head] - `(V "Cons" (to-array [~head ~tail]))) - `(V "Nil" nil) - elems)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 6f626c2eb..bade1e90c 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -3,11 +3,13 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :refer [match]] - (lux [base :as & :refer [exec return* return fail fail* - repeat-m exhaust-m try-m try-all-m map-m mapcat-m reduce-m - apply-m - normalize-ident]] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [exec return* return fail fail* assert! + repeat% exhaust% try% try-all% map% flat-map% fold% sequence% + apply% + normalize-ident + |get |list]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -362,35 +364,35 @@ (let [compiler-step (exec [analysis+ (&optimizer/optimize eval!) ;; :let [_ (prn 'analysis+ analysis+)] ] - (mapcat-m compile-statement analysis+))] + (flat-map% compile-statement analysis+))] (defn ^:private compile-module [name] (fn [state] - (if (-> state ::&/modules (contains? name)) + (if (->> state (get$ "modules") (|contains? name)) (fail "[Compiler Error] Can't redefine a module!") (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (&host/->class name) nil "java/lang/Object" nil))] - (match (&/run-state (exhaust-m compiler-step) (-> state - (assoc ::&/source (slurp (str "source/" name ".lux")) - ::&/global-env (&/env name) - ::&/writer =class) - (assoc-in [::&/modules name] &a-def/init-module))) - [::&/ok [?state ?vals]] + (matchv ::M/objects [(&/run-state (exhaust% compiler-step) (-> state + (set$ "source" (slurp (str "source/" name ".lux"))) + (set$ "global-env" (&/env name)) + (set$ "writer" =class) + (update$ "modules" #(|put name &a-def/init-module %))))] + [["Right" [?state ?vals]]] (do (.visitEnd =class) ;; (prn 'compile-module/?vals ?vals) (&/run-state (&&/save-class! name (.toByteArray =class)) ?state)) - [::&/failure ?message] + [["Left" ?message]] (fail* ?message))))))) ;; [Resources] (defn compile-all [modules] (.mkdir (java.io.File. "output")) - (match (&/run-state (map-m compile-module modules) (&/init-state)) - [::&/ok [?state _]] + (matchv ::M/objects [(&/run-state (map% compile-module modules) (&/init-state))] + [["Right" [?state _]]] (println (str "Compilation complete! " (pr-str modules))) - [::&/failure ?message] + [["Left" ?message]] (do (prn 'compile-all '?message ?message) (assert false ?message)))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index c302ef75d..f3f65d2b5 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,25 +1,26 @@ (ns lux.lexer (:require [clojure.template :refer [do-template]] [lux.base :as & :refer [exec return* return fail fail* - repeat-m try-m try-all-m]])) + |list + try-all%]])) ;; [Utils] (defn ^:private lex-regex [regex] (fn [state] - (if-let [[match] (re-find regex (::&/source state))] - (return* (update-in state [::&/source] #(.substring % (.length match))) match) + (if-let [[match] (re-find regex (get$ "source" state))] + (return* (update$ "source" #(.substring % (.length match)) state) match) (fail* (str "[Lexer Error] Pattern failed: " regex))))) (defn ^:private lex-regex2 [regex] (fn [state] - (if-let [[match tok1 tok2] (re-find regex (::&/source state))] - (return* (update-in state [::&/source] #(.substring % (.length match))) [tok1 tok2]) + (if-let [[match tok1 tok2] (re-find regex (get$ "source" state))] + (return* (update$ "source" #(.substring % (.length match)) state) [tok1 tok2]) (fail* (str "[Lexer Error] Pattern failed: " regex))))) (defn ^:private lex-prefix [prefix] (fn [state] - (if (.startsWith (::&/source state) prefix) - (return* (update-in state [::&/source] #(.substring % (.length prefix))) prefix) + (if (.startsWith (get$ "source" state) prefix) + (return* (update$ "source" #(.substring % (.length prefix)) state) prefix) (fail* (str "[Lexer Error] Text failed: " prefix))))) (defn ^:private escape-char [escaped] @@ -35,98 +36,98 @@ (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (def ^:private lex-text-body - (try-all-m [(exec [[prefix escaped] (lex-regex2 #"(?s)^([^\"\\]*)(\\.)") - unescaped (escape-char escaped) - postfix lex-text-body] - (return (str prefix unescaped postfix))) - (lex-regex #"(?s)^([^\"\\]*)")])) + (try-all% (|list (exec [[prefix escaped] (lex-regex2 #"(?s)^([^\"\\]*)(\\.)") + unescaped (escape-char escaped) + postfix lex-text-body] + (return (str prefix unescaped postfix))) + (lex-regex #"(?s)^([^\"\\]*)")))) (def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)(;[0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]+)?") ;; [Lexers] (def ^:private lex-white-space (exec [white-space (lex-regex #"^(\s+)")] - (return [::white-space white-space]))) + (return (V "White_Space" white-space)))) (def ^:private lex-single-line-comment (exec [_ (lex-prefix "##") comment (lex-regex #"^([^\n]*)") _ (lex-regex #"^(\n?)")] - (return [::comment comment]))) + (return (V "Comment" comment)))) (def ^:private lex-multi-line-comment (exec [_ (lex-prefix "#(") - comment (try-all-m [(lex-regex #"(?is)^((?!#\().)*?(?=\)#)") - (exec [pre (lex-regex #"(?is)^(.+?(?=#\())") - [_ inner] lex-multi-line-comment - post (lex-regex #"(?is)^(.+?(?=\)#))")] - (return (str pre "#(" inner ")#" post)))]) + comment (try-all% (|list (lex-regex #"(?is)^((?!#\().)*?(?=\)#)") + (exec [pre (lex-regex #"(?is)^(.+?(?=#\())") + [_ inner] lex-multi-line-comment + post (lex-regex #"(?is)^(.+?(?=\)#))")] + (return (str pre "#(" inner ")#" post))))) _ (lex-prefix ")#")] - (return [::comment comment]))) + (return (V "Comment" comment)))) (def ^:private lex-comment - (try-all-m [lex-single-line-comment - lex-multi-line-comment])) + (try-all% (|list lex-single-line-comment + lex-multi-line-comment))) (do-template [<name> <tag> <regex>] (def <name> (exec [token (lex-regex <regex>)] - (return [<tag> token]))) + (return (V <tag> token)))) - ^:private lex-bool ::bool #"^(true|false)" - ^:private lex-real ::real #"^-?(0|[1-9][0-9]*)\.[0-9]+" - ^:private lex-int ::int #"^-?(0|[1-9][0-9]*)" - ^:private lex-ident ::ident +ident-re+) + ^:private lex-bool "Bool" #"^(true|false)" + ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+" + ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)" + ^:private lex-ident "Ident" +ident-re+) (def ^:private lex-char (exec [_ (lex-prefix "#\"") - token (try-all-m [(exec [escaped (lex-regex #"^(\\.)")] - (escape-char escaped)) - (lex-regex #"^(.)")]) + token (try-all% (|list (exec [escaped (lex-regex #"^(\\.)")] + (escape-char escaped)) + (lex-regex #"^(.)"))) _ (lex-prefix "\"")] - (return [::char token]))) + (return (V "Char" token)))) (def ^:private lex-text (exec [_ (lex-prefix "\"") token lex-text-body _ (lex-prefix "\"")] - (return [::text token]))) + (return (V "Text" token)))) (def ^:private lex-tag (exec [_ (lex-prefix "#") token (lex-regex +ident-re+)] - (return [::tag token]))) + (return (V "Tag" token)))) (do-template [<name> <text> <tag>] (def <name> (exec [_ (lex-prefix <text>)] - (return [<tag>]))) - - ^:private lex-open-paren "(" ::open-paren - ^:private lex-close-paren ")" ::close-paren - ^:private lex-open-bracket "[" ::open-bracket - ^:private lex-close-bracket "]" ::close-bracket - ^:private lex-open-brace "{" ::open-brace - ^:private lex-close-brace "}" ::close-brace + (return (V <tag> nil)))) + + ^:private lex-open-paren "(" "Open_Paren" + ^:private lex-close-paren ")" "Close_Paren" + ^:private lex-open-bracket "[" "Open_Bracket" + ^:private lex-close-bracket "]" "Close_Bracket" + ^:private lex-open-brace "{" "Open_Brace" + ^:private lex-close-brace "}" "Close_Brace" ) (def ^:private lex-delimiter - (try-all-m [lex-open-paren - lex-close-paren - lex-open-bracket - lex-close-bracket - lex-open-brace - lex-close-brace])) + (try-all% (|list lex-open-paren + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) ;; [Exports] (def lex - (try-all-m [lex-white-space - lex-comment - lex-bool - lex-real - lex-int - lex-char - lex-text - lex-ident - lex-tag - lex-delimiter])) + (try-all% (|list lex-white-space + lex-comment + lex-bool + lex-real + lex-int + lex-char + lex-text + lex-ident + lex-tag + lex-delimiter))) diff --git a/src/lux/macro.clj b/src/lux/macro.clj index 9a2b7e2d9..b822426ff 100644 --- a/src/lux/macro.clj +++ b/src/lux/macro.clj @@ -6,14 +6,8 @@ ;; [Resources] (defn expand [loader macro-class tokens] (fn [state] - (let [output (-> (.loadClass loader macro-class) - (.getField "_datum") - (.get nil) - (.apply tokens) - (.apply state))] - (matchv ::M/objects [output] - [["Ok" [state* tokens*]]] - (return* state* tokens*) - - [["Error" ?msg]] - (fail* ?msg))))) + (-> (.loadClass loader macro-class) + (.getField "_datum") + (.get nil) + (.apply tokens) + (.apply state)))) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index d60458b2f..b2af943a5 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -1,80 +1,77 @@ (ns lux.parser (:require [clojure.template :refer [do-template]] - [clojure.core.match :refer [match]] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array (lux [base :as & :refer [exec return fail repeat-m]] [lexer :as &lexer]))) ;; [Utils] -(do-template [<name> <close-token> <description> <tag>] +(do-template [<name> <close-tag> <description> <tag>] (defn <name> [parse] - (exec [elems (repeat-m parse) + (exec [elems (repeat% parse) token &lexer/lex] - (if (= <close-token> token) - (return (|list (&/V <tag> (reduce #(&/V "Cons" (to-array [%2 %1])) - (&/V "Nil" nil) - (reverse (apply concat elems)))))) + (matchv ::M/objects [token] + [[<close-token> _]] + (return (|list (&/V <tag> (|concat elems)))) + [_] (fail (str "[Parser Error] Unbalanced " <description> "."))))) - ^:private parse-form [::&lexer/close-paren] "parantheses" "Form" - ^:private parse-tuple [::&lexer/close-bracket] "brackets" "Tuple" + ^:private parse-form "Close_Paren" "parantheses" "Form" + ^:private parse-tuple "Close_Bracket" "brackets" "Tuple" ) (defn ^:private parse-record [parse] - (exec [elems* (repeat-m parse) + (exec [elems* (repeat% parse) token &lexer/lex - :let [elems (apply concat elems*)]] - (cond (not= [::&lexer/close-brace] token) - (fail (str "[Parser Error] Unbalanced braces.")) + :let [elems (|concat elems*)]] + (matchv ::M/objects [token] + [["Close_Brace" _]] + (fail (str "[Parser Error] Unbalanced braces.")) - (odd? (count elems)) - (fail (str "[Parser Error] Records must have an even number of elements.")) - - :else - (return (|list (&/V "Record" (reduce #(&/V "Cons" (to-array [%2 %1])) - (&/V "Nil" nil) - (reverse elems)))))))) + [_] + (if (even? (|length elems)) + (return (|list (&/V "Record" (|as-pairs elems)))) + (fail (str "[Parser Error] Records must have an even number of elements.")))))) ;; [Interface] (def parse (exec [token &lexer/lex ;; :let [_ (prn 'parse/token token)] ] - (match token - [::&lexer/white-space _] + (matchv ::M/objects [token] + [["White_Space" _]] (return (|list)) - [::&lexer/comment _] + [["Comment" _]] (return (|list)) - [::&lexer/bool ?value] + [["Bool" ?value]] (return (|list (&/V "Bool" (Boolean/parseBoolean ?value)))) - [::&lexer/int ?value] + [["Int" ?value]] (return (|list (&/V "Int" (Integer/parseInt ?value)))) - [::&lexer/real ?value] + [["Real" ?value]] (return (|list (&/V "Real" (Float/parseFloat ?value)))) - [::&lexer/char ?value] + [["Char" ?value]] (return (|list (&/V "Char" (.charAt ?value 0)))) - [::&lexer/text ?value] + [["Text" ?value]] (return (|list (&/V "Text" ?value))) - [::&lexer/ident ?value] + [["Ident" ?value]] (return (|list (&/V "Ident" ?value))) - [::&lexer/tag ?value] + [["Tag" ?value]] (return (|list (&/V "Tag" ?value))) - [::&lexer/open-paren] + [["Open_Paren" _]] (parse-form parse) - [::&lexer/open-bracket] + [["Open-Bracket" _]] (parse-tuple parse) - [::&lexer/open-brace] + [["Open_Brace"]] (parse-record parse) - - _ - (fail (str "[Parser Error] Unmatched token: " token))))) + ))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 9c3e6f35b..6e8996f2a 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -2,36 +2,39 @@ (:refer-clojure :exclude [deref apply merge]) (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array - [lux.base :as & :refer [exec return* return fail fail* - |get - repeat-m try-m try-all-m map-m - sequence-m - apply-m assert!]])) + [lux.base :as & :refer [exec return* return fail fail* assert! + |list |map fold |length |interpose |get zip2 |keys + repeat% exhaust% try% try-all% map% flat-map% fold% sequence% + apply% + normalize-ident]])) ;; [Util] (def ^:private success (return nil)) (defn ^:private deref [id] (fn [state] - (if-let [type (get-in state [::&/types :mappings id])] - [::&/ok [state type]] - [::&/failure (str "Unknown type-var: " id)]))) + (if-let [type (->> state (get$ "types") (get$ "mappings") (|get id))] + (return* state type) + (fail* (str "Unknown type-var: " id))))) (defn ^:private reset [id type] (fn [state] - (if-let [_ (get-in state [::&/types :mappings id])] - [::&/ok [(assoc-in state [::&/types :mappings id] (&/V "Some" type)) nil]] - [::&/failure (str "Unknown type-var: " id)]))) + (if-let [_ (->> state (get$ "types") (get$ "mappings") (|get id))] + (return* (update$ "types" (fn [ts] (update$ "mappings" #(|put id (&/V "Some" type) %) + ts)) + state) + nil) + (fail* (str "Unknown type-var: " id))))) ;; [Exports] (def fresh-var (fn [state] - (let [id (-> state ::&/types :counter)] - [::&/ok [(update-in state [::&/types] - #(-> % - (update-in [:counter] inc) - (assoc-in [:mappings id] (&/V "None" nil)))) - (&/V "Var" id)]]))) + (let [id (->> state (get$ "types") (get$ "counter"))] + (return* (update$ "types" #(-> % + (update$ "counter" inc) + (update$ "mappings" #(|put id (&/V "None" nil) %))) + state) + (&/V "Var" id))))) (def fresh-lambda (exec [=arg fresh-var @@ -81,31 +84,30 @@ )) (def +list+ - [::All (&/|->list (list)) "List" "a" - [::Variant (&/|->list (list ["Cons" [::Tuple (&/|->list (list [::Bound "a"] [::App [::Bound "List"] [::Bound "a"]]))]] - ["Nil" [::Tuple (&/|->list (list))]] - ))]]) + [::All (|list) "List" "a" + [::Variant (|list ["Cons" [::Tuple (|list [::Bound "a"] [::App [::Bound "List"] [::Bound "a"]])]] + ["Nil" [::Tuple (|list)]])]]) (def +type+ - (let [text [::Data "java.lang.String" (&/|->list (list))] + (let [text [::Data "java.lang.String" (|list)] type [::App [::Bound "Type"] [::Any]] list-of-types [::App +list+ type] - string=>type [::App +list+ [::Tuple (&/|->list (list text type))]]] - (->type [::All (&/|->list (list)) "Type" "_" - [::Variant (&/|->list (list ["Any" [::Tuple (&/|->list (list))]] - ["Nothing" [::Tuple (&/|->list (list))]] - ["Data" [::Tuple (&/|->list (list text list-of-types))]] - ["Tuple" list-of-types] - ["Variant" string=>type] - ["Record" string=>type] - ["Lambda" [::Tuple (&/|->list (list type - type))]] - ["App" [::Tuple (&/|->list (list type - type))]] - ["Bound" text] - ["Var" [::Data "java.lang.Long" (&/|->list (list))]] - ["All" [::Tuple (&/|->list (list string=>type text text type))]] - ))]]))) + string=>type [::App +list+ [::Tuple (|list text type)]]] + (->type [::All (|list) "Type" "_" + [::Variant (|list ["Any" [::Tuple (|list)]] + ["Nothing" [::Tuple (|list)]] + ["Data" [::Tuple (|list text list-of-types)]] + ["Tuple" list-of-types] + ["Variant" string=>type] + ["Record" string=>type] + ["Lambda" [::Tuple (|list type + type)]] + ["App" [::Tuple (|list type + type)]] + ["Bound" text] + ["Var" [::Data "java.lang.Long" (|list)]] + ["All" [::Tuple (|list string=>type text text type)]] + )]]))) (defn clean [type] (matchv ::M/objects [type] @@ -124,34 +126,89 @@ (return (&/V "App" (to-array [=lambda =param])))) [["Tuple" ?members]] - (exec [=members (&/|map% clean ?members)] + (exec [=members (map% clean ?members)] (return (&/V "Tuple" =members))) [["Variant" ?members]] - (exec [=members (&/|map% (fn [[k v]] - (exec [=v (clean v)] - (return (to-array [k =v])))) - ?members)] + (exec [=members (map% (fn [[k v]] + (exec [=v (clean v)] + (return (to-array [k =v])))) + ?members)] (return (&/V "Variant" =members))) [["Record" ?members]] - (exec [=members (&/|map% (fn [[k v]] - (exec [=v (clean v)] - (return (to-array [k =v])))) - ?members)] + (exec [=members (map% (fn [[k v]] + (exec [=v (clean v)] + (return (to-array [k =v])))) + ?members)] (return (&/V "Record" =members))) [["All" [?env ?name ?arg ?body]]] - (exec [=env (&/|map% (fn [[k v]] - (exec [=v (clean v)] - (return (to-array [k =v])))) - ?env)] + (exec [=env (map% (fn [[k v]] + (exec [=v (clean v)] + (return (to-array [k =v])))) + ?env)] (return (&/V "All" (to-array [=env ?name ?arg ?body])))) [_] (return type) )) +(defn ^:private show-type [type] + (matchv ::M/objects [type] + [["Any" _]] + "Any" + + [["Nothing" _]] + "Nothing" + + [["Data" [name params]]] + (str "(^ " name " [" (->> params (|map show-type) (|interpose " ") (fold str "")) "])") + + [["Tuple" elems]] + (str "(, " (->> elems (|map show-type) (|interpose " ") (fold str "")) ")") + + [["Variant" cases]] + (str "(| " (->> cases + (|map (fn [kv] + (matchv ::M/objects [kv] + [[k ["Tuple" ["Nil" _]]]] + (str "#" k) + + [[k v]] + (str "(#" k " " (show-type v) ")")))) + (|interpose " ") + (fold str "")) ")") + + + [["Record" fields]] + (str "(& " (->> fields + (|map (fn [kv] + (matchv ::M/objects [kv] + [[k v]] + (str "(#" k " " (show-type v) ")")))) + (|interpose " ") + (fold str "")) ")") + + [["Lambda" [input output]]] + (str "(-> " (show-type input) " " (show-type output) ")") + + [["Var" id]] + (str "⌈" id "⌋") + + [["Bound" name]] + name + + [["App" [?lambda ?param]]] + (str "(" (show-type ?lambda) " " (show-type ?param) ")") + + [["All" [?env ?name ?arg ?body]]] + (str "(All " ?name " " ?arg " " (show-type ?body) ")") + )) + +(defn ^:private solve-error [expected actual] + (str "Type " (show-type expected) " does not subsume type " (show-type actual))) + (defn solve [expected actual] (matchv ::M/objects [expected actual] [["Any" _] _] @@ -167,32 +224,22 @@ (fail (str "not (" actual " <= " expected ")"))) [["Tuple" e!elems] ["Tuple" a!elems]] - (exec [:let [e!elems (&/->seq e!elems) - a!elems (&/->seq a!elems)] - _ (assert! (= (count e!elems) (count a!elems)) + (exec [_ (assert! (= (|length e!elems) (|length a!elems)) "Tuples must have matching element sizes.") - _ (map-m (fn [n g] (solve n g)) - (map vector e!elems a!elems))] + _ (map% (fn [n g] (solve n g)) + (zip2 e!elems a!elems))] success) [["Variant" e!cases] ["Variant" a!cases]] - (exec [:let [e!cases (reduce #(assoc %1 (aget %2 0) (aget %2 1)) {} (&/->seq e!cases)) - a!cases (reduce #(assoc %1 (aget %2 0) (aget %2 1)) {} (&/->seq a!cases))] - _ (assert! (every? (partial contains? e!cases) (keys a!cases)) - "The given variant contains unhandled cases.") - _ (map-m (fn [label] - (solve (get e!cases label) (get a!cases label))) - (keys a!cases))] + (exec [_ (map% (fn [slot] + (solve (|get e!cases slot) (|get a!cases slot))) + (|keys a!cases))] success) [["Record" e!fields] ["Record" a!fields]] - (exec [:let [e!fields (reduce #(assoc %1 (aget %2 0) (aget %2 1)) {} (&/->seq e!fields)) - a!fields (reduce #(assoc %1 (aget %2 0) (aget %2 1)) {} (&/->seq a!fields))] - _ (assert! (every? (partial contains? a!fields) (keys e!fields)) - "The given record lacks necessary fields.") - _ (map-m (fn [label] - (solve (get e!fields label) (get a!fields label))) - (keys e!fields))] + (exec [_ (map% (fn [slot] + (solve (|get e!fields slot) (|get a!fields slot))) + (|keys e!fields))] success) [["Lambda" [e!input e!output]] ["Lambda" [a!input a!output]]] @@ -210,6 +257,9 @@ _ (solve expected =a!type) _ (reset a!id =a!type)] success) + + [_ _] + (solve-error expected actual) )) (let [&& #(and %1 %2)] @@ -264,10 +314,10 @@ (defn slot-type [record slot] (fn [state] (matchv ::M/objects [(|get record slot)] - [["Error" msg]] + [["Left" msg]] (fail* msg) - [["Ok" type]] + [["Right" type]] (return* state type)))) (def +dont-care+ (&/V "Any" nil)) |