From b0d7e67b72fae763050b050d3452514db57ac682 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 18 Feb 2015 01:14:16 -0400 Subject: [Refactor] - Split lux/analyser/env into "env" & "def" modules. - Renamed lux/analyser/util to "base". --- src/lux/analyser.clj | 6 +- src/lux/analyser/base.clj | 6 +- src/lux/analyser/case.clj | 6 +- src/lux/analyser/def.clj | 43 +++++++ src/lux/analyser/env.clj | 66 +++-------- src/lux/analyser/host.clj | 10 +- src/lux/analyser/lambda.clj | 10 +- src/lux/analyser/lux.clj | 83 +++++++------- src/lux/base.clj | 274 ++++++++++++++++++++++++++++++++++++++++++++ src/lux/compiler.clj | 30 ++--- src/lux/compiler/base.clj | 10 +- src/lux/compiler/case.clj | 22 ++-- src/lux/compiler/host.clj | 28 ++--- src/lux/compiler/lambda.clj | 14 +-- src/lux/compiler/lux.clj | 38 +++--- src/lux/host.clj | 6 +- src/lux/lexer.clj | 16 +-- src/lux/parser.clj | 2 +- src/lux/type.clj | 32 +++--- src/lux/util.clj | 273 ------------------------------------------- 20 files changed, 492 insertions(+), 483 deletions(-) create mode 100644 src/lux/analyser/def.clj create mode 100644 src/lux/base.clj delete mode 100644 src/lux/util.clj (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index a9cd8670e..06567423e 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,9 +1,9 @@ (ns lux.analyser (:require (clojure [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail - try-all-m map-m mapcat-m reduce-m - assert!]] + (lux [base :as & :refer [exec return fail + try-all-m map-m mapcat-m reduce-m + assert!]] [parser :as &parser] [type :as &type] [macro :as ¯o] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 4ed3ef569..c4da0511d 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -1,8 +1,8 @@ (ns lux.analyser.base (:require [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail - try-all-m map-m mapcat-m reduce-m - assert!]]))) + (lux [base :as & :refer [exec return fail + try-all-m map-m mapcat-m reduce-m + assert!]]))) ;; [Resources] (defn expr-type [syntax+] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 8fa8ff29f..bbd454fc1 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,8 +1,8 @@ (ns lux.analyser.case (:require [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail - try-all-m map-m mapcat-m reduce-m - assert!]] + (lux [base :as & :refer [exec return fail + try-all-m map-m mapcat-m reduce-m + assert!]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] diff --git a/src/lux/analyser/def.clj b/src/lux/analyser/def.clj new file mode 100644 index 000000000..c8994bc67 --- /dev/null +++ b/src/lux/analyser/def.clj @@ -0,0 +1,43 @@ +(ns lux.analyser.def + (:require [clojure.core.match :refer [match]] + (lux [base :as & :refer [exec return fail + if-m try-all-m map-m mapcat-m reduce-m + assert!]]) + [lux.analyser.base :as &&])) + +;; [Exports] +(defn defined? [module name] + (fn [state] + [::&/ok [state (get-in state [::&/modules module name :defined?])]])) + +(defn annotated? [module name] + (fn [state] + [::&/ok [state (boolean (get-in state [::&/modules module name]))]])) + +(defn macro? [module name] + (fn [state] + [::&/ok [state (boolean (get-in state [::&/modules module :macros name]))]])) + +(defn annotate [module name access type] + (fn [state] + (let [full-name (str module &/+name-separator+ name) + bound [::&&/Expression [::&&/global module name] type]] + [::&/ok [(-> state + (assoc-in [::&/modules module name] {:args-n [:None] + :access access + :type type + :defined? false}) + (update-in [::&/global-env] merge {full-name bound, name bound})) + nil]]))) + +(defn declare-macro [module name] + (fn [state] + [::&/ok [(assoc-in state [::&/modules module :macros name] true) + nil]])) + +(defn define [module name] + (if-m (annotated? module name) + (fn [state] + [::&/ok [(assoc-in state [::&/modules module name :defined?] true) + nil]]) + (fail (str "[Analyser Error] Can't define an unannotated element: " name)))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 177aa54dd..020b9a899 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,55 +1,19 @@ (ns lux.analyser.env (:require [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail - if-m try-all-m map-m mapcat-m reduce-m - assert!]]) + (lux [base :as & :refer [exec return fail + if-m try-all-m map-m mapcat-m reduce-m + assert!]]) [lux.analyser.base :as &&])) -;; [Resources] +;; [Exports] (def next-local-idx (fn [state] - [::&util/ok [state (-> state ::&util/local-envs first :locals :counter)]])) - -(defn defined? [module name] - (fn [state] - [::&util/ok [state (get-in state [::&util/modules module name :defined?])]])) - -(defn annotated? [module name] - (fn [state] - [::&util/ok [state (boolean (get-in state [::&util/modules module name]))]])) - -(defn macro? [module name] - (fn [state] - [::&util/ok [state (boolean (get-in state [::&util/modules module :macros name]))]])) - -(defn annotate [module name access type] - (fn [state] - (let [full-name (str module &util/+name-separator+ name) - bound [::&&/Expression [::&&/global module name] type]] - [::&util/ok [(-> state - (assoc-in [::&util/modules module name] {:args-n [:None] - :access access - :type type - :defined? false}) - (update-in [::&util/global-env] merge {full-name bound, name bound})) - nil]]))) - -(defn declare-macro [module name] - (fn [state] - [::&util/ok [(assoc-in state [::&util/modules module :macros name] true) - nil]])) - -(defn define [module name] - (if-m (annotated? module name) - (fn [state] - [::&util/ok [(assoc-in state [::&util/modules module name :defined?] true) - nil]]) - (fail (str "[Analyser Error] Can't define an unannotated element: " name)))) + [::&/ok [state (-> state ::&/local-envs first :locals :counter)]])) (defn with-local [name mode type body] (fn [state] - (let [old-mappings (-> state ::&util/local-envs first (get-in [:locals :mappings])) - =return (body (update-in state [::&util/local-envs] + (let [old-mappings (-> state ::&/local-envs first (get-in [:locals :mappings])) + =return (body (update-in state [::&/local-envs] (fn [[top & stack]] (let [bound-unit (case mode :self [::&&/self (list)] @@ -59,13 +23,13 @@ (assoc-in [:locals :mappings name] [::&&/Expression bound-unit type])) stack)))))] (match =return - [::&util/ok [?state ?value]] - [::&util/ok [(update-in ?state [::&util/local-envs] (fn [[top* & stack*]] - (cons (-> top* - (update-in [:locals :counter] dec) - (assoc-in [:locals :mappings] old-mappings)) - stack*))) - ?value]] + [::&/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]] _ =return)))) @@ -78,4 +42,4 @@ (def captured-vars (fn [state] - [::&util/ok [state (-> state ::&util/local-envs first :closure :mappings)]])) + [::&/ok [state (-> state ::&/local-envs first :closure :mappings)]])) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5a7585226..e27745748 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -1,9 +1,9 @@ (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail - try-all-m map-m mapcat-m reduce-m - assert!]] + (lux [base :as & :refer [exec return fail + try-all-m map-m mapcat-m reduce-m + assert!]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -112,7 +112,7 @@ :let [=fields (into {} (for [[class field] ?fields] [field {:access :public :type class}]))] - $module &util/get-module-name] + $module &/get-module-name] (return (list [::&&/Statement [::&&/jvm-class $module ?name ?super-class =fields {}]])))) (defn analyse-jvm-interface [analyse ?name ?members] @@ -131,7 +131,7 @@ :let [=methods (into {} (for [[method [inputs output]] ?members] [method {:access :public :type [inputs output]}]))] - $module &util/get-module-name] + $module &/get-module-name] (return (list [::&&/Statement [::&&/jvm-interface $module ?name =methods]])))) (defn analyse-exec [analyse ?exprs] diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index dab4e8901..be7000acd 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,15 +1,15 @@ (ns lux.analyser.lambda (:require [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail - try-all-m map-m mapcat-m reduce-m - assert!]]) + (lux [base :as & :refer [exec return fail + try-all-m map-m mapcat-m reduce-m + assert!]]) (lux.analyser [base :as &&] [env :as &env]))) ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - (&util/with-closure - (exec [scope-name &util/get-scope-name] + (&/with-closure + (exec [scope-name &/get-scope-name] (&env/with-local self :self self-type (&env/with-local arg :local arg-type (exec [=return body diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index ba6f40ff3..c821a085d 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -1,39 +1,40 @@ (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail - if-m try-all-m map-m mapcat-m reduce-m - assert!]] + (lux [base :as & :refer [exec return fail + if-m try-all-m map-m mapcat-m reduce-m + assert!]] [parser :as &parser] [type :as &type] [macro :as ¯o] [host :as &host]) - (lux.analyser [base :as &] + (lux.analyser [base :as &&] [lambda :as &&lambda] [case :as &&case] - [env :as &&env]))) + [env :as &&env] + [def :as &&def]))) ;; [Resources] (defn analyse-tuple [analyse ?elems] (exec [=elems (mapcat-m analyse ?elems) - =elems-types (map-m &/expr-type =elems) + =elems-types (map-m &&/expr-type =elems) ;; :let [_ (prn 'analyse-tuple =elems)] ] - (return (list [::&/Expression [::&/tuple =elems] [::&type/Tuple =elems-types]])))) + (return (list [::&&/Expression [::&&/tuple =elems] [::&type/Tuple =elems-types]])))) (defn analyse-ident [analyse ident] (fn [state] - (let [[top & stack*] (::&util/local-envs state)] + (let [[top & stack*] (::&/local-envs state)] (if-let [=bound (or (get-in top [:locals :mappings ident]) (get-in top [:closure :mappings ident]))] - [::&util/ok [state (list =bound)]] + [::&/ok [state (list =bound)]] (let [no-binding? #(and (-> % :locals :mappings (contains? ident) not) (-> % :closure :mappings (contains? ident) not)) [inner outer] (split-with no-binding? stack*)] (if (empty? outer) - (if-let [global (get-in state [::&util/global-env ident])] - [::&util/ok [state (list global)]] - [::&util/failure (str "[Analyser Error] Unresolved identifier: " ident)]) + (if-let [global (get-in state [::&/global-env ident])] + [::&/ok [state (list global)]] + [::&/failure (str "[Analyser Error] Unresolved identifier: " ident)]) (let [[=local inner*] (reduce (fn [[register new-inner] frame] (let [[register* frame*] (&&lambda/close-over (:name frame) ident register frame)] [register* (cons frame* new-inner)])) @@ -41,19 +42,19 @@ (get-in (first outer) [:closure :mappings ident])) '()] (reverse (cons top inner)))] - [::&util/ok [(assoc state ::&util/local-envs (concat inner* outer)) (list =local)]]) + [::&/ok [(assoc state ::&/local-envs (concat inner* outer)) (list =local)]]) )) )) )) (defn analyse-call [analyse ?fn ?args] - (exec [=fn (&/analyse-1 analyse ?fn) - loader &util/loader] + (exec [=fn (&&/analyse-1 analyse ?fn) + loader &/loader] (match =fn - [::&/Expression =fn-form =fn-type] + [::&&/Expression =fn-form =fn-type] (match =fn-form - [::&/global ?module ?name] - (exec [macro? (&&env/macro? ?module ?name)] + [::&&/global ?module ?name] + (exec [macro? (&&def/macro? ?module ?name)] (if macro? (let [macro-class (&host/location (list ?name ?module)) [macro-expansion state*] (¯o/expand loader macro-class ?args)] @@ -66,18 +67,18 @@ (if (> needs-num provides-num) [needs-num [::&type/function (drop provides-num ?fargs) ?freturn]] [needs-num &type/+dont-care-type+])))]] - (return (list [::&/Expression [::&/static-call needs-num =fn =args] =return-type]))))) + (return (list [::&&/Expression [::&&/static-call needs-num =fn =args] =return-type]))))) _ (exec [=args (mapcat-m analyse ?args)] - (return (list [::&/Expression [::&/call =fn =args] &type/+dont-care-type+])))) + (return (list [::&&/Expression [::&&/call =fn =args] &type/+dont-care-type+])))) :else (fail "Can't call something without a type.")) )) (defn analyse-case [analyse ?variant ?branches] - (exec [=variant (&/analyse-1 analyse ?variant) + (exec [=variant (&&/analyse-1 analyse ?variant) _ (assert! (and (> (count ?branches) 0) (even? (count ?branches))) "Unbalanced branches in \"case'\" expression.") :let [branches (partition 2 ?branches) @@ -87,53 +88,53 @@ =bodies (map-m (partial &&case/analyse-branch analyse max-locals) (map vector locals-per-branch (map second branches))) :let [_ (prn 'analyse-case/=bodies =bodies)] - =body-types (map-m &/expr-type =bodies) + =body-types (map-m &&/expr-type =bodies) =case-type (reduce-m &type/merge [::&type/Nothing] =body-types) :let [=branches (map vector (map first branches) =bodies)]] - (return (list [::&/Expression [::&/case =variant base-register max-locals =branches] =case-type])))) + (return (list [::&&/Expression [::&&/case =variant base-register max-locals =branches] =case-type])))) (defn analyse-lambda [analyse ?self ?arg ?body] (exec [[_ =arg =return :as =lambda-type] &type/fresh-function [=scope =captured =body] (&&lambda/with-lambda ?self =lambda-type ?arg =arg - (&/analyse-1 analyse ?body)) - =body-type (&/expr-type =body) + (&&/analyse-1 analyse ?body)) + =body-type (&&/expr-type =body) =lambda-type (exec [_ (&type/solve =return =body-type)] (&type/clean =lambda-type)) :let [=lambda-form (match =body - [::&/Expression [::&/lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] _] - [::&/lambda =scope =captured (cons ?arg ?sub-args) (&&lambda/raise-expr ?arg ?sub-body)] + [::&&/Expression [::&&/lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] _] + [::&&/lambda =scope =captured (cons ?arg ?sub-args) (&&lambda/raise-expr ?arg ?sub-body)] _ - [::&/lambda =scope =captured (list ?arg) =body])]] - (return (list [::&/Expression =lambda-form =lambda-type])))) + [::&&/lambda =scope =captured (list ?arg) =body])]] + (return (list [::&&/Expression =lambda-form =lambda-type])))) (defn analyse-def [analyse ?name ?value] ;; (prn 'analyse-def ?name ?value) - (exec [module-name &util/get-module-name] - (if-m (&&env/defined? module-name ?name) + (exec [module-name &/get-module-name] + (if-m (&&def/defined? module-name ?name) (fail (str "Can't redefine " ?name)) - (exec [=value (&/analyse-1 analyse ?value) + (exec [=value (&&/analyse-1 analyse ?value) =value (match =value - [::&/Expression =value-form =value-type] + [::&&/Expression =value-form =value-type] (return (match =value-form - [::&/lambda ?old-scope ?env ?args ?body] - [::&/Expression [::&/lambda (list module-name ?name) ?env ?args ?body] =value-type] + [::&&/lambda ?old-scope ?env ?args ?body] + [::&&/Expression [::&&/lambda (list module-name ?name) ?env ?args ?body] =value-type] _ =value)) _ (fail "")) - =value-type (&/expr-type =value) - _ (if-m (&&env/annotated? module-name ?name) + =value-type (&&/expr-type =value) + _ (if-m (&&def/annotated? module-name ?name) (return nil) - (&&env/annotate module-name ?name :public =value-type)) - _ (&&env/define module-name ?name)] - (return (list [::&/Statement [::&/def ?name =value]])))))) + (&&def/annotate module-name ?name :public =value-type)) + _ (&&def/define module-name ?name)] + (return (list [::&&/Statement [::&&/def ?name =value]])))))) (defn analyse-declare-macro [?ident] - (exec [_ (&&env/annotate ?ident :public [::&type/Any])] + (exec [_ (&&def/annotate ?ident :public [::&type/Any])] (return (list)))) (defn analyse-require [analyse ?path] diff --git a/src/lux/base.clj b/src/lux/base.clj new file mode 100644 index 000000000..599ff6c72 --- /dev/null +++ b/src/lux/base.clj @@ -0,0 +1,274 @@ +(ns lux.base + (:require (clojure [template :refer [do-template]]) + [clojure.core.match :refer [match]])) + +;; [Resources] +;; [Resources/Contants] +(def +name-separator+ ";") + +;; [Resources/Utils] +(defn fail* [message] + [::failure message]) + +(defn return* [state value] + [::ok [state value]]) + +;; [Resources/Monads] +(defn fail [message] + (fn [_] + [::failure message])) + +(defn return [value] + (fn [state] + [::ok [state value]])) + +(defn bind [m-value step] + (fn [state] + (let [inputs (m-value state)] + (match inputs + [::ok [?state ?datum]] + ((step ?datum) ?state) + + [::failure _] + inputs)))) + +(defmacro exec [steps return] + (assert (not= 0 (count steps)) "The steps can't be empty!") + (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") + (reduce (fn [inner [label computation]] + (case label + :let `(let ~computation ~inner) + ;; else + `(bind ~computation (fn [~label] ~inner)))) + return + (reverse (partition 2 steps)))) + +;; [Resources/Combinators] +(defn try-m [monad] + (fn [state] + (match (monad state) + [::ok [?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 '()))))) + +(def source-consumed? + (fn [state] + [::ok [state (empty? (::source state))]])) + +(defn exhaust-m [monad] + (exec [output-h monad + ? source-consumed? + output-t (if ? + (return (list)) + (exhaust-m monad))] + (return (cons output-h output-t)))) + +(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 if-m [text-m then-m else-m] + (exec [? text-m] + (if ? + then-m + else-m))) + +(do-template [ ] + (defn [f inputs] + (if (empty? inputs) + (return '()) + (exec [output (f (first inputs)) + outputs ( f (rest inputs))] + (return ( output outputs))))) + + map-m cons + mapcat-m concat) + +(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] + (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]] + + [::failure _] + output)))) + +(defn assert! [test message] + (if test + (return nil) + (fail message))) + +(defn comp-m [f-m g-m] + (exec [temp g-m] + (f-m temp))) + +(defn pass [m-value] + (fn [state] + m-value)) + +(def get-state + (fn [state] + (return* state state))) + +(defn sequence-m [m-values] + (match m-values + ([head & tail] :seq) + (exec [_ head] + (sequence-m tail)) + + _ + (return nil))) + +(defn ^:private normalize-char [char] + (case char + \* "_ASTER_" + \+ "_PLUS_" + \- "_DASH_" + \/ "_SLASH_" + \\ "_BSLASH_" + \_ "_UNDERS_" + \% "_PERCENT_" + \$ "_DOLLAR_" + \' "_QUOTE_" + \` "_BQUOTE_" + \@ "_AT_" + \^ "_CARET_" + \& "_AMPERS_" + \= "_EQ_" + \! "_BANG_" + \? "_QM_" + \: "_COLON_" + \; "_SCOLON_" + \. "_PERIOD_" + \, "_COMMA_" + \< "_LT_" + \> "_GT_" + \~ "_TILDE_" + ;; default + char)) + +(defn normalize-ident [ident] + (reduce str "" (map normalize-char ident))) + +(def loader + (fn [state] + (return* state (::loader state)))) + +(def +init-bindings+ + {:counter 0 + :mappings {}}) + +(defn env [name] + {: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.)}) + +(def get-writer + (fn [state] + (if-let [datum (::writer state)] + [::ok [state datum]] + [::failure "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."]))) + +(def get-current-module-env + (fn [state] + (if-let [datum (::global-env state)] + [::ok [state datum]] + [::failure "Module hasn't been set."]))) + +(def get-module-name + (exec [module get-current-module-env] + (return (: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]] + + _ + 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)]))))] + (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))))))) + +(def get-scope-name + (exec [module-name get-module-name] + (fn [state] + [::ok [state (->> state ::local-envs (map :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]] + + _ + output)))) + +(defn run-state [monad state] + (monad state)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index dcfbfed56..17748a1eb 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -4,10 +4,10 @@ [set :as set] [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :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]] + (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]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -192,31 +192,31 @@ (mapcat-m compile-statement analysis+))] (defn ^:private compile-module [name] (fn [state] - (if (-> state ::&util/modules (contains? name)) + (if (-> state ::&/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 (&util/run-state (exhaust-m compiler-step) (assoc state - ::&util/source (slurp (str "source/" name ".lux")) - ::&util/global-env (&util/env name) - ::&util/writer =class)) - [::&util/ok [?state ?vals]] + (match (&/run-state (exhaust-m compiler-step) (assoc state + ::&/source (slurp (str "source/" name ".lux")) + ::&/global-env (&/env name) + ::&/writer =class)) + [::&/ok [?state ?vals]] (do (.visitEnd =class) (prn 'compile-module/?vals ?vals) - (&util/run-state (&&/save-class! name (.toByteArray =class)) ?state)) + (&/run-state (&&/save-class! name (.toByteArray =class)) ?state)) - [::&util/failure ?message] + [::&/failure ?message] (fail* ?message))))))) ;; [Resources] (defn compile-all [modules] (.mkdir (java.io.File. "output")) - (match (&util/run-state (map-m compile-module modules) (&util/init-state)) - [::&util/ok [?state _]] + (match (&/run-state (map-m compile-module modules) (&/init-state)) + [::&/ok [?state _]] (println (str "Compilation complete! " (pr-str modules))) - [::&util/failure ?message] + [::&/failure ?message] (assert false ?message))) (comment diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 7896902be..28c793e10 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,9 +1,9 @@ (ns lux.compiler.base (:require [clojure.string :as string] - (lux [util :as &util :refer [exec return* return fail fail* - repeat-m exhaust-m try-m try-all-m map-m reduce-m - apply-m - normalize-ident]])) + (lux [base :as & :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -30,7 +30,7 @@ (.loadClass loader name)) (defn save-class! [name bytecode] - (exec [loader &util/loader + (exec [loader &/loader :let [_ (write-class name bytecode) _ (load-class! loader (string/replace name #"/" "."))]] (return nil))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 2139bb24a..0f49c08b5 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -2,10 +2,10 @@ (:require (clojure [set :as set] [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return* return fail fail* - repeat-m exhaust-m try-m try-all-m map-m reduce-m - apply-m - normalize-ident]] + (lux [base :as & :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -330,8 +330,8 @@ [::&parser/Tuple ?members] (match pm [::TuplePM ?num-elems ?branches ?defaults] - (exec [_ (&util/assert! (= ?num-elems (count ?members)) - (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))] + (exec [_ (&/assert! (= ?num-elems (count ?members)) + (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))] (return [::TuplePM ?num-elems (cons [?members body] ?branches) ?defaults])) [::?PM ?defaults] @@ -346,8 +346,8 @@ (match pm [::VariantPM ?variants ?branches ?defaults] (exec [variants* (if-let [?num-elems (get ?variants ?tag)] - (exec [_ (&util/assert! (= ?num-elems num-members) - (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))] + (exec [_ (&/assert! (= ?num-elems num-members) + (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))] (return ?variants)) (return (assoc ?variants ?tag num-members)))] (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults])) @@ -364,8 +364,8 @@ (match pm [::VariantPM ?variants ?branches ?defaults] (exec [variants* (if-let [?num-elems (get ?variants ?tag)] - (exec [_ (&util/assert! (= ?num-elems num-members) - (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))] + (exec [_ (&/assert! (= ?num-elems num-members) + (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))] (return ?variants)) (return (assoc ?variants ?tag num-members)))] (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults])) @@ -544,7 +544,7 @@ ;; [Resources] (let [ex-class (&host/->class "java.lang.IllegalStateException")] (defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (prn "Has writer")] :let [$start (new Label) $end (new Label) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index db62312ec..acddcf8cb 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -3,10 +3,10 @@ [set :as set] [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return* return fail fail* - repeat-m exhaust-m try-m try-all-m map-m reduce-m - apply-m - normalize-ident]] + (lux [base :as & :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -60,7 +60,7 @@ (do-template [ ] (defn [compile *type* ?x ?y] (exec [:let [+wrapper-class+ (&host/->class )] - *writer* &util/get-writer + *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) @@ -100,7 +100,7 @@ ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (map-m (fn [[class-name arg]] (exec [ret (compile arg) @@ -113,7 +113,7 @@ (return nil))) (defn compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] @@ -128,7 +128,7 @@ (return nil))) (defn compile-jvm-new [compile *type* ?class ?classes ?args] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V") class* (&host/->class ?class) _ (doto *writer* @@ -144,14 +144,14 @@ (return nil))) (defn compile-jvm-new-array [compile *type* ?class ?length] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int ?length)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] (return nil))) (defn compile-jvm-aastore [compile *type* ?array ?idx ?elem] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* (.visitInsn Opcodes/DUP) @@ -161,7 +161,7 @@ (return nil))) (defn compile-jvm-aaload [compile *type* ?array ?idx] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* (.visitLdcInsn (int ?idx)) @@ -169,12 +169,12 @@ (return nil))) (defn compile-jvm-getstatic [compile *type* ?class ?field] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] (return nil))) (defn compile-jvm-getfield [compile *type* ?class ?field ?object] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] @@ -216,7 +216,7 @@ (&&/save-class! full-name (.toByteArray =interface)))) (defn compile-exec [compile *type* ?exprs] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer _ (map-m (fn [expr] (exec [ret (compile expr) :let [_ (.visitInsn *writer* Opcodes/POP)]] diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index d0588e073..0b7ad1183 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -3,9 +3,9 @@ [set :as set] [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return* return fail fail* - repeat-m exhaust-m try-m try-all-m map-m reduce-m - normalize-ident]] + (lux [base :as & :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + normalize-ident]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -111,10 +111,10 @@ (.visitEnd)))) (defn ^:private add-lambda-impl [class compile impl-signature impl-body] - (&util/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) - (.visitCode)) + (&/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) + (.visitCode)) (exec [;; :let [_ (prn 'add-lambda-impl/_0)] - *writer* &util/get-writer + *writer* &/get-writer ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)] ret (compile impl-body) ;; :let [_ (prn 'add-lambda-impl/_2 ret)] @@ -127,7 +127,7 @@ (return ret)))) (defn ^:private instance-closure [compile lambda-class closed-over args init-signature] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 13925a50c..4635bfa1a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -3,10 +3,10 @@ [set :as set] [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return* return fail fail* - repeat-m exhaust-m try-m try-all-m map-m reduce-m - apply-m - normalize-ident]] + (lux [base :as & :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -23,8 +23,8 @@ ;; [Utils] (defn ^:private compile-field [compile ?name body] - (exec [*writer* &util/get-writer - module-name &util/get-module-name + (exec [*writer* &/get-writer + module-name &/get-module-name :let [outer-class (&host/->class module-name) datum-sig (&host/->type-signature "java.lang.Object") current-class (&host/location (list ?name outer-class)) @@ -34,8 +34,8 @@ current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))))] - _ (&util/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (exec [*writer* &util/get-writer + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (exec [*writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile body) :let [_ (doto *writer* @@ -52,14 +52,14 @@ (let [+class+ (&host/->class "java.lang.Boolean") +sig+ (&host/->type-signature "java.lang.Boolean")] (defn compile-bool [compile *type* ?value] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]] (return nil)))) (do-template [ ] (let [+class+ (&host/->class )] (defn [compile *type* value] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW ) (.visitInsn Opcodes/DUP) @@ -73,12 +73,12 @@ ) (defn compile-text [compile *type* ?value] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) (defn compile-tuple [compile *type* ?elems] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [num-elems (count ?elems) tuple-class (&host/->class (str &host/tuple-class num-elems)) _ (doto *writer* @@ -94,7 +94,7 @@ (return nil))) (defn compile-variant [compile *type* ?tag ?members] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [variant-class* (str (&host/->class &host/variant-class) (count ?members)) _ (doto *writer* (.visitTypeInsn Opcodes/NEW variant-class*) @@ -112,12 +112,12 @@ (return nil))) (defn compile-local [compile *type* ?idx] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] (return nil))) (defn compile-captured [compile *type* ?scope ?captured-id ?source] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD @@ -127,12 +127,12 @@ (return nil))) (defn compile-global [compile *type* ?owner-class ?name] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]] (return nil))) (defn compile-call [compile *type* ?fn ?args] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer _ (compile ?fn) _ (map-m (fn [arg] (exec [ret (compile arg) @@ -143,7 +143,7 @@ (defn compile-static-call [compile *type* ?needs-num ?fn ?args] (assert false (pr-str 'compile-static-call)) - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (match (:form ?fn) [::&a/global ?owner-class ?fn-name] (let [arg-sig (&host/->type-signature "java.lang.Object") @@ -187,7 +187,7 @@ (fail "Can only define expressions.")))) (defn compile-self-call [compile ?assumed-args] - (exec [*writer* &util/get-writer + (exec [*writer* &/get-writer :let [_ (.visitVarInsn *writer* Opcodes/ALOAD 0)] _ (map-m (fn [arg] (exec [ret (compile arg) diff --git a/src/lux/host.clj b/src/lux/host.clj index 04d0cd9dd..9cf4f85c0 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -2,9 +2,9 @@ (:require (clojure [string :as string] [template :refer [do-template]]) [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return* return fail fail* - repeat-m try-all-m map-m mapcat-m reduce-m - normalize-ident]] + (lux [base :as & :refer [exec return* return fail fail* + repeat-m try-all-m map-m mapcat-m reduce-m + normalize-ident]] [parser :as &parser] [type :as &type]))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 2e0abea82..4ad36f669 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,25 +1,25 @@ (ns lux.lexer (:require [clojure.template :refer [do-template]] - [lux.util :as &util :refer [exec return* return fail fail* - repeat-m try-m try-all-m]])) + [lux.base :as & :refer [exec return* return fail fail* + repeat-m try-m try-all-m]])) ;; [Utils] (defn ^:private lex-regex [regex] (fn [state] - (if-let [[match] (re-find regex (::&util/source state))] - (return* (update-in state [::&util/source] #(.substring % (.length match))) match) + (if-let [[match] (re-find regex (::&/source state))] + (return* (update-in state [::&/source] #(.substring % (.length match))) match) (fail* (str "[Lexer Error] Pattern failed: " regex))))) (defn ^:private lex-regex2 [regex] (fn [state] - (if-let [[match tok1 tok2] (re-find regex (::&util/source state))] - (return* (update-in state [::&util/source] #(.substring % (.length match))) [tok1 tok2]) + (if-let [[match tok1 tok2] (re-find regex (::&/source state))] + (return* (update-in state [::&/source] #(.substring % (.length match))) [tok1 tok2]) (fail* (str "[Lexer Error] Pattern failed: " regex))))) (defn ^:private lex-prefix [prefix] (fn [state] - (if (.startsWith (::&util/source state) prefix) - (return* (update-in state [::&util/source] #(.substring % (.length prefix))) prefix) + (if (.startsWith (::&/source state) prefix) + (return* (update-in state [::&/source] #(.substring % (.length prefix))) prefix) (fail* (str "[Lexer Error] Text failed: " prefix))))) (defn ^:private escape-char [escaped] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index a74251d6d..1b31e8da7 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -1,7 +1,7 @@ (ns lux.parser (:require [clojure.template :refer [do-template]] [clojure.core.match :refer [match]] - (lux [util :as &util :refer [exec return fail repeat-m]] + (lux [base :as & :refer [exec return fail repeat-m]] [lexer :as &lexer]))) ;; [Utils] diff --git a/src/lux/type.clj b/src/lux/type.clj index f558f1fc8..339a030d9 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,35 +1,35 @@ (ns lux.type (:refer-clojure :exclude [deref apply merge]) (:require [clojure.core.match :refer [match]] - [lux.util :as &util :refer [exec return* return fail fail* - repeat-m try-m try-all-m map-m - sequence-m - apply-m assert!]])) + [lux.base :as & :refer [exec return* return fail fail* + repeat-m try-m try-all-m map-m + sequence-m + apply-m assert!]])) ;; [Util] (def ^:private success (return nil)) (defn ^:private deref [id] (fn [state] - (if-let [top+bottom (get-in state [::&util/types :mappings id])] - [::&util/ok [state top+bottom]] - [::&util/failure (str "Unknown type-var: " id)]))) + (if-let [top+bottom (get-in state [::&/types :mappings id])] + [::&/ok [state top+bottom]] + [::&/failure (str "Unknown type-var: " id)]))) (defn ^:private update [id top bottom] (fn [state] - (if-let [top+bottom (get-in state [::&util/types :mappings id])] - [::&util/ok [(assoc-in state [::&util/types :mappings id] [top bottom]) nil]] - [::&util/failure (str "Unknown type-var: " id)]))) + (if-let [top+bottom (get-in state [::&/types :mappings id])] + [::&/ok [(assoc-in state [::&/types :mappings id] [top bottom]) nil]] + [::&/failure (str "Unknown type-var: " id)]))) ;; [Interface] (def fresh-var (fn [state] - (let [id (-> state ::&util/types :counter)] - [::&util/ok [(update-in state [::&util/types] - #(-> % - (update-in [:counter] inc) - (assoc-in [:mappings id] [[::Any] [::Nothing]]))) - [::Var id]]]))) + (let [id (-> state ::&/types :counter)] + [::&/ok [(update-in state [::&/types] + #(-> % + (update-in [:counter] inc) + (assoc-in [:mappings id] [[::Any] [::Nothing]]))) + [::Var id]]]))) (def fresh-function (exec [=arg fresh-var diff --git a/src/lux/util.clj b/src/lux/util.clj deleted file mode 100644 index c27e05ab8..000000000 --- a/src/lux/util.clj +++ /dev/null @@ -1,273 +0,0 @@ -(ns lux.util - (:require (clojure [template :refer [do-template]]) - [clojure.core.match :refer [match]])) - -;; [Resources] -;; [Resources/Contants] -(def +name-separator+ ";") - -;; [Resources/Utils] -(defn fail* [message] - [::failure message]) - -(defn return* [state value] - [::ok [state value]]) - -;; [Resources/Monads] -(defn fail [message] - (fn [_] - [::failure message])) - -(defn return [value] - (fn [state] - [::ok [state value]])) - -(defn bind [m-value step] - #(let [inputs (m-value %)] - (match inputs - [::ok [?state ?datum]] - ((step ?datum) ?state) - - [::failure _] - inputs))) - -(defmacro exec [steps return] - (assert (not= 0 (count steps)) "The steps can't be empty!") - (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") - (reduce (fn [inner [label computation]] - (case label - :let `(let ~computation ~inner) - ;; else - `(bind ~computation (fn [~label] ~inner)))) - return - (reverse (partition 2 steps)))) - -;; [Resources/Combinators] -(defn try-m [monad] - (fn [state] - (match (monad state) - [::ok [?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 '()))))) - -(def source-consumed? - (fn [state] - [::ok [state (empty? (::source state))]])) - -(defn exhaust-m [monad] - (exec [output-h monad - ? source-consumed? - output-t (if ? - (return (list)) - (exhaust-m monad))] - (return (cons output-h output-t)))) - -(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 if-m [text-m then-m else-m] - (exec [? text-m] - (if ? - then-m - else-m))) - -(do-template [ ] - (defn [f inputs] - (if (empty? inputs) - (return '()) - (exec [output (f (first inputs)) - outputs ( f (rest inputs))] - (return ( output outputs))))) - - map-m cons - mapcat-m concat) - -(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] - (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]] - - [::failure _] - output)))) - -(defn assert! [test message] - (if test - (return nil) - (fail message))) - -(defn comp-m [f-m g-m] - (exec [temp g-m] - (f-m temp))) - -(defn pass [m-value] - (fn [state] - m-value)) - -(def get-state - (fn [state] - (return* state state))) - -(defn sequence-m [m-values] - (match m-values - ([head & tail] :seq) - (exec [_ head] - (sequence-m tail)) - - _ - (return nil))) - -(defn ^:private normalize-char [char] - (case char - \* "_ASTER_" - \+ "_PLUS_" - \- "_DASH_" - \/ "_SLASH_" - \\ "_BSLASH_" - \_ "_UNDERS_" - \% "_PERCENT_" - \$ "_DOLLAR_" - \' "_QUOTE_" - \` "_BQUOTE_" - \@ "_AT_" - \^ "_CARET_" - \& "_AMPERS_" - \= "_EQ_" - \! "_BANG_" - \? "_QM_" - \: "_COLON_" - \; "_SCOLON_" - \. "_PERIOD_" - \, "_COMMA_" - \< "_LT_" - \> "_GT_" - \~ "_TILDE_" - ;; default - char)) - -(defn normalize-ident [ident] - (reduce str "" (map normalize-char ident))) - -(def loader - (fn [state] - (return* state (::loader state)))) - -(def +init-bindings+ - {:counter 0 - :mappings {}}) - -(defn env [name] - {: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.)}) - -(def get-writer - (fn [state] - (if-let [datum (::writer state)] - [::ok [state datum]] - [::failure "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."]))) - -(def get-current-module-env - (fn [state] - (if-let [datum (::global-env state)] - [::ok [state datum]] - [::failure "Module hasn't been set."]))) - -(def get-module-name - (exec [module get-current-module-env] - (return (: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]] - - _ - 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)]))))] - (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))))))) - -(def get-scope-name - (exec [module-name get-module-name] - (fn [state] - [::ok [state (->> state ::local-envs (map :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]] - - _ - output)))) - -(defn run-state [monad state] - (monad state)) -- cgit v1.2.3