diff options
| -rw-r--r-- | src/lux/analyser/lux.clj | 34 | ||||
| -rw-r--r-- | src/lux/analyser/module.clj | 65 | ||||
| -rw-r--r-- | src/lux/analyser/record.clj | 6 | ||||
| -rw-r--r-- | src/lux/base.clj | 36 |
4 files changed, 93 insertions, 48 deletions
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 0bfa647e5..1844aab3d 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -122,8 +122,10 @@ (&/$UnivQ _) (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems))] + [[tuple-type tuple-cursor] tuple-analysis] (&/with-scope-type-var $var-id + (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))] (return (&/|list (&&/|meta exo-type tuple-cursor tuple-analysis)))) @@ -222,8 +224,10 @@ (&/$UnivQ _) (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) + (&/with-scope-type-var $var-id + (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values))) (&/$ExQ _) (&type/with-var @@ -379,16 +383,18 @@ (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] (|case (&&meta/meta-get &&meta/macro?-tag ?meta) (&/$Some _) - (|do [macro-expansion (fn [state] (try (-> ?value (.apply ?args) (.apply state)) - (catch java.lang.StackOverflowError e - (|let [[r-prefix r-name] real-name] - (do (.printStackTrace e) - (throw e)))))) + (|do [macro-expansion (fn [state] + (|case (-> ?value (.apply ?args) (.apply state)) + (&/$Right state* output) + (&/$Right (&/T [state* output])) + + (&/$Left error) + ((&/fail-with-loc error) state))) module-name &/get-module-name ;; :let [[r-prefix r-name] real-name - ;; _ (when (or (= "defsig" r-name) - ;; (= "deftype" r-name) - ;; (= "@type" r-name) + ;; _ (when (or (= "defstruct" r-name) + ;; (= "struct" r-name) + ;; ;; (= "@type" r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") @@ -493,8 +499,10 @@ (|case exo-type (&/$UnivQ _) (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] exo-type** (&type/apply-type exo-type* $var)] - (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + (&/with-scope-type-var $var-id + (analyse-lambda* analyse exo-type** ?self ?arg ?body))) (&/$ExQ _) (&type/with-var @@ -523,8 +531,10 @@ (|case exo-type (&/$UnivQ _) (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] exo-type* (&type/apply-type exo-type $var) - [_ _expr] (analyse-lambda** analyse exo-type* ?self ?arg ?body) + [_ _expr] (&/with-scope-type-var $var-id + (analyse-lambda** analyse exo-type* ?self ?arg ?body)) _cursor &/cursor] (return (&&/|meta exo-type _cursor _expr))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index c15062783..3ee9d28d4 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -9,7 +9,7 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftuple |let |do return return* fail fail* |case]] + (lux [base :as & :refer [deftuple |let |do return return* |case]] [type :as &type] [host :as &host]) [lux.host.generics :as &host-generics] @@ -42,7 +42,8 @@ (|do [current-module &/get-module-name] (fn [state] (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports))) - (fail* (str "[Analyser Error] Can't import module " (pr-str module) " twice @ " current-module)) + ((&/fail-with-loc (str "[Analyser Error] Can't import module " (pr-str module) " twice @ " current-module)) + state) (return* (&/update$ &/$modules (fn [ms] (&/|update current-module @@ -81,7 +82,8 @@ nil) _ - (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))))) + ((&/fail-with-loc (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name)) + state)))) (defn def-type [module name] "(-> Text Text (Lux Type))" @@ -90,8 +92,10 @@ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[?type ?meta ?value] $def] (return* state ?type)) - (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) - (fail* (str "[Analyser Error] Unknown module: " module))))) + ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (str module ";" name))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) + state)))) (defn type-def [module name] "(-> Text Text (Lux [Bool Type]))" @@ -110,9 +114,12 @@ ?value])) _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name]))))) - (fail* (str "[Analyser Error] Unknown module: " module))))) + ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) + state))) + ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) + state)))) (defn exists? [name] "(-> Text (Lux Bool))" @@ -125,12 +132,14 @@ (fn [state] (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) - (fail* (str "[Analyser Error] Unknown alias: " name)))))) + ((&/fail-with-loc (str "[Analyser Error] Unknown alias: " name)) + state))))) (defn alias [module alias reference] (fn [state] (if-let [real-name (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $module-aliases) (&/|get alias))] - (fail* (str "[Analyser Error] Can't re-use alias \"" alias "\" @ " module)) + ((&/fail-with-loc (str "[Analyser Error] Can't re-use alias \"" alias "\" @ " module)) + state) (return* (->> state (&/update$ &/$modules (fn [ms] @@ -161,9 +170,12 @@ (return* state (&/T [(&/T [module name]) $def])) _ - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) - (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) - (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) + ((&/fail-with-loc (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))) + state)))) + ((&/fail-with-loc (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Module doesn't exist: " module)) + state))))) (defn ensure-type-def [def-data] "(-> DefData (Lux Type))" @@ -173,7 +185,7 @@ (return ?type) _ - (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))) + (&/fail-with-loc (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))) (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] @@ -204,7 +216,8 @@ (fn [state] (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (return* state (&/get$ <tag> =module)) - (fail* (str "[Lux Error] Unknown module: " module))) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state)) )) tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" @@ -215,7 +228,7 @@ (|do [tags-table (tags-by-module module) _ (&/map% (fn [tag] (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T [module tag])))) + (&/fail-with-loc (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T [module tag])))) (return nil))) tags)] (return nil))) @@ -250,7 +263,8 @@ =modules)) state) nil)) - (fail* (str "[Lux Error] Unknown module: " module)))))) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state))))) (defn ensure-can-see-tag [module tag-name] "(-> Text Text (Lux Unit))" @@ -262,9 +276,12 @@ (if (or ?exported (= module current-module)) (return* state &/unit-tag) - (fail* (str "[Analyser Error] Can't access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module)))) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name]))))) - (fail* (str "[Module Error] Unknown module: " module)))))) + ((&/fail-with-loc (str "[Analyser Error] Can't access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module)) + state))) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state))))) (do-template [<name> <part> <doc>] (defn <name> [module tag-name] @@ -274,8 +291,10 @@ (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] (return* state <part>)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name]))))) - (fail* (str "[Module Error] Unknown module: " module))))) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state)))) tag-index ?idx "(-> Text Text (Lux Int))" tag-group ?tags "(-> Text Text (Lux (List Ident)))" @@ -302,7 +321,7 @@ (|case (&meta/meta-get <tag> meta) (&/$Some (&/$BoolM true)) (&/try-all% (&/|list (&type/check <type> type) - (fail (str "[Analyser Error] Can't tag as lux;" <desc> "? if it's not a " <desc> ": " (str module ";" name))))) + (&/fail-with-loc (str "[Analyser Error] Can't tag as lux;" <desc> "? if it's not a " <desc> ": " (str module ";" name))))) _ (return nil))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 335b46dbb..81332b34c 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -25,7 +25,7 @@ (return (&/T [tags type]))) _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv [[_ (&/$TagS k)] v] @@ -33,7 +33,7 @@ (return (&/T [(&/ident->text =k) v]))) _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) pairs) _ (let [num-expected (&/|length tag-group) num-got (&/|length =pairs)] @@ -42,6 +42,6 @@ =members (&/map% (fn [tag] (if-let [member (&/|get tag =pairs)] (return member) - (fail (str "[Analyser Error] Missing tag: " tag)))) + (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag)))) (&/|map &/ident->text tag-group))] (return (&/T [=members tag-type])))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 54baf16bb..d9198885e 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -2,7 +2,6 @@ ;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. ;; If a copy of the MPL was not distributed with this file, ;; You can obtain one at http://mozilla.org/MPL/2.0/. - (ns lux.base (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] @@ -149,6 +148,7 @@ "type-vars" "expected" "seed" + "scope-type-vars" "host"]) ;; Compiler @@ -592,10 +592,20 @@ $Nil xs)) +(defn add-loc [meta ^String msg] + (if (.startsWith msg "@") + msg + (|let [[file line col] meta] + (str "@ " file "," line "," col "\n" msg)))) + +(defn fail-with-loc [msg] + (fn [state] + (fail* (add-loc (get$ $cursor state) msg)))) + (defn assert! [test message] (if test (return unit-tag) - (fail message))) + (fail-with-loc message))) (def get-state (fn [state] @@ -764,6 +774,8 @@ $None ;; "lux;seed" 0 + ;; scope-type-vars + $Nil ;; "lux;host" (host nil)] )) @@ -1256,12 +1268,16 @@ (defn |partition [n xs] (->> xs ->seq (partition-all n) (map ->list) ->list)) -(defn add-loc [meta ^String msg] - (if (.startsWith msg "@") - msg - (|let [[file line col] meta] - (str "@ " file "," line "," col "\n" msg)))) - -(defn fail-with-loc [msg] +(defn with-scope-type-var [id body] (fn [state] - (fail* (add-loc (get$ $cursor state) msg)))) + (|case (body (set$ $scope-type-vars + ($Cons id (get$ $scope-type-vars state)) + state)) + ($Right [state* output]) + ($Right (T [(set$ $scope-type-vars + (get$ $scope-type-vars state) + state*) + output])) + + ($Left msg) + ($Left msg)))) |