aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2016-05-14 19:46:19 -0400
committerEduardo Julian2016-05-14 19:46:19 -0400
commitb55a0a3f09d54bc2ef99891f1a40df8efa6a028f (patch)
treeb1a3d82652cd82725a88293de08b15e66263bc04
parentf112989822f9ece0485ff8f5eb8df671655929b8 (diff)
- Now storing the type-variables created during type-checking for the sake of reference later on in definitions.
-rw-r--r--src/lux/analyser/lux.clj34
-rw-r--r--src/lux/analyser/module.clj65
-rw-r--r--src/lux/analyser/record.clj6
-rw-r--r--src/lux/base.clj36
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))))