aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux100
-rw-r--r--src/lux/analyser/case.clj5
-rw-r--r--src/lux/analyser/lux.clj33
-rw-r--r--src/lux/type.clj111
4 files changed, 110 insertions, 139 deletions
diff --git a/source/lux.lux b/source/lux.lux
index e97d01759..94f4853d8 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -1281,89 +1281,53 @@
#Nil
#None))
-## (def #export (find-macro ident state)
-## (-> Ident ($' Lux Macro))
-## (let [[module name] ident]
-## (case' state
-## {#source source #modules modules #module-aliases module-aliases
-## #envs envs #types types #host host
-## #seed seed}
-## (case' (:' ($' Maybe Macro)
-## (do Maybe:Monad
-## [bindings (get module modules)
-## gdef (get name bindings)]
-## (case' gdef
-## (#MacroD macro')
-## (#Some macro')
-
-## _
-## #None)))
-## (#Some macro)
-## (#Right [state macro])
-
-## #None
-## (#Left ($ text:++ "There is no macro by the name: " module ";" name))))))
-
(def #export (find-macro ident state)
- (-> Ident ($' Lux Macro))
+ (-> Ident ($' Lux ($' Maybe Macro)))
(let [[module name] ident]
(case' state
{#source source #modules modules #module-aliases module-aliases
#envs envs #types types #host host
#seed seed}
- (case' (:' ($' Maybe Macro)
- (case' (get module modules)
- (#Some bindings)
- (case' (get name bindings)
- (#Some gdef)
- (case' gdef
- (#MacroD macro')
- (#Some macro')
-
- _
- #None)
-
- #None
- #None)
-
- #None
- #None))
- (#Some macro)
- (#Right [state macro])
+ (#Right [state (do Maybe:Monad
+ [bindings (get module modules)
+ gdef (get name bindings)]
+ (case' (:' ($' DefData' Macro) gdef)
+ (#MacroD macro')
+ (#Some macro')
- #None
- (#Left ($ text:++ "There is no macro by the name: " module ";" name))))))
+ _
+ #None))]))))
-(def (join-list xs)
+(def (list:join xs)
(All [a]
(-> ($' List ($' List a)) ($' List a)))
(fold list:++ #Nil xs))
-## (def #export (macro-expand syntax state)
-## (-> Syntax ($' Lux ($' List Syntax)))
-## (case' syntax
-## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))])
-## (do Lux:Monad
-## [macro' (find-macro macro-name)]
-## (case' macro'
-## (#Some macro)
-## (do Lux:Monad
-## [expansion (macro args)
-## expansion' (map% Lux:Monad macro-expand expansion)]
-## (return (:' SyntaxList (join-list expansion'))))
+(def #export (macro-expand syntax)
+ (-> Syntax ($' Lux ($' List Syntax)))
+ (case' syntax
+ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))])
+ (do Lux:Monad
+ [?macro (find-macro macro-name)]
+ (case' (:' ($' Maybe Macro) ?macro)
+ (#Some macro)
+ (do Lux:Monad
+ [expansion (macro args)
+ expansion' (map% Lux:Monad macro-expand expansion)]
+ (;return (:' SyntaxList (list:join expansion'))))
-## #None
-## (do Lux:Monad
-## [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))]
-## (return (:' Syntax (list ($form (join-list parts'))))))))
+ #None
+ (do Lux:Monad
+ [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))]
+ (;return (:' SyntaxList (list ($form (list:join parts'))))))))
-## (#Meta [_ (#Tuple members)])
-## (do Lux:Monad
-## [members' (map% Lux:Monad macro-expand members)]
-## (return (:' Syntax (list ($tuple (join-list members'))))))
+ (#Meta [_ (#Tuple members)])
+ (do Lux:Monad
+ [members' (map% Lux:Monad macro-expand members)]
+ (;return (:' SyntaxList (list ($tuple (list:join members'))))))
-## _
-## (return (:' SyntaxList (list syntax)))))
+ _
+ (return (:' SyntaxList (list syntax)))))
## ## (def (walk-type type)
## ## (-> Syntax ($' Lux Syntax))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 8fa2bbaff..2e1dd5278 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -10,8 +10,9 @@
;; [Utils]
(defn ^:private resolve-type [type]
(matchv ::M/objects [type]
- [["lux;VarT" ?idx]]
- (|do [type* (&type/deref ?idx)]
+ [["lux;VarT" ?id]]
+ (|do [type* (&/try-all% (&/|list (&type/deref ?id)
+ (fail "##9##")))]
(resolve-type type*))
[_]
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index fc99fa50f..c964058b2 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -52,7 +52,8 @@
(|do [;; :let [_ (prn 'analyse-variant/exo-type (&type/show-type exo-type))]
exo-type* (matchv ::M/objects [exo-type]
[["lux;VarT" ?id]]
- (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
+ (&/try-all% (&/|list (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id)
+ (fail "##8##")))]
(&type/actual-type exo-type*))
(|do [_ (&type/set-var ?id &type/Type)]
(&type/actual-type &type/Type))))
@@ -85,7 +86,8 @@
(defn analyse-record [analyse exo-type ?elems]
(|do [exo-type* (matchv ::M/objects [exo-type]
[["lux;VarT" ?id]]
- (|do [exo-type* (&type/deref ?id)]
+ (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id)
+ (fail "##7##")))]
(&type/actual-type exo-type*))
[_]
@@ -112,11 +114,6 @@
?elems)]
(return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type))))))
-(defn ^:private show-frame [frame]
- (str "{{" (->> frame (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)
- &/|keys &/->seq (interpose " ") (reduce str ""))
- "}}"))
-
(defn analyse-symbol [analyse exo-type ident]
(|do [module-name &/get-module-name]
(fn [state]
@@ -224,12 +221,22 @@
(fn [$var]
(|do [type* (&type/apply-type ?fun-type* $var)
output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)]
- (matchv ::M/objects [output]
- [[?expr* ?type*]]
- (|do [type** (&type/clean $var ?type*)]
+ (matchv ::M/objects [output $var]
+ [[?expr* ?type*] ["lux;VarT" ?id]]
+ ;; (|do [? (&type/bound? ?id)]
+ ;; (if ?
+ ;; (return (&/T ?expr* ?type*))
+ ;; (|do [type** (&type/clean $var ?type*)]
+ ;; (return (&/T ?expr* type**)))))
+ (|do [? (&type/bound? ?id)
+ _ (if ?
+ (return nil)
+ (|do [ex &type/existential]
+ (&type/set-var ?id ex)))
+ type** (&type/clean $var ?type*)]
(return (&/T ?expr* type**)))
- [_]
+ [_ _]
(assert false (prn-str 'analyse-apply*/output (aget output 0)))))))
[["lux;LambdaT" [?input-t ?output-t]]]
@@ -315,7 +322,8 @@
[["lux;VarT" ?id]]
(|do [? (&type/bound? ?id)]
(if ?
- (|do [dtype (&type/deref ?id)]
+ (|do [dtype (&/try-all% (&/|list (&type/deref ?id)
+ (fail "##6##")))]
(matchv ::M/objects [dtype]
[["lux;ExT" _]]
(return (&/T _expr exo-type))
@@ -366,6 +374,7 @@
;; :let [_ (prn 'analyse-def/_1)]
=value-type (&&/expr-type =value)
;; :let [_ (prn 'analyse-def/_2)]
+ ;; _ &type/delete-vars
:let [_ (prn 'analyse-def/TYPE ?name ;; (&type/show-type =value-type)
)
_ (println)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index ce16cec3d..caa210d2a 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -174,16 +174,23 @@
(defn deref [id]
(fn [state]
(let [mappings (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS))]
- (do ;; (prn 'deref/mappings (&/->seq (&/|keys mappings)))
- (if-let [type* (->> mappings (&/|get id))]
- (do ;; (prn 'deref/type* (aget type* 0))
- (matchv ::M/objects [type*]
- [["lux;Some" type]]
- (return* state type)
-
- [["lux;None" _]]
- (fail* (str "[Type Error] Unbound type-var: " id))))
- (fail* (str "[Type Error] <deref> Unknown type-var: " id)))))))
+ (if-let [type* (->> mappings (&/|get id))]
+ (matchv ::M/objects [type*]
+ [["lux;Some" type]]
+ (return* state type)
+
+ [["lux;None" _]]
+ (fail* (str "[Type Error] Unbound type-var: " id)))
+ (fail* (str "[Type Error] <deref> Unknown type-var: " id))))))
+
+(defn set-var* [id type]
+ (fn [state]
+ (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
+ (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
+ ts))
+ state)
+ nil)
+ (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
(defn set-var [id type]
(fn [state]
@@ -212,13 +219,17 @@
state)
id))))
+(def existential
+ (|do [seed &/gen-id]
+ (return (&/V "lux;ExT" seed))))
+
(declare clean*)
(defn ^:private delete-var [id]
(|do [? (bound? id)
_ (if ?
(return nil)
- (|do [seed &/gen-id]
- (set-var id (&/V "lux;ExT" seed))))]
+ (|do [ex existential]
+ (set-var id ex)))]
(fn [state]
(&/run-state (|do [mappings* (&/map% (fn [binding]
(|let [[?id ?type] binding]
@@ -257,6 +268,11 @@
_ (delete-var id)]
(return output)))
+;; (def delete-vars
+;; (|do [vars #(->> % (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|keys (return* %))
+;; _ (&/map% delete-var vars)]
+;; (return nil)))
+
(defn with-vars [amount k]
(|do [=vars (&/map% (constantly create-var) (&/|range amount))
output (k (&/|map #(&/V "lux;VarT" %) =vars))
@@ -268,8 +284,7 @@
[["lux;VarT" ?id]]
(if (= ?tid ?id)
(&/try-all% (&/|list (deref ?id)
- (return type)))
- ;; (deref ?id)
+ (fail "##5##")))
(return type))
[["lux;LambdaT" [?arg ?return]]]
@@ -569,16 +584,12 @@
[["lux;VarT" ?eid] ["lux;VarT" ?aid]]
(if (= ?eid ?aid)
(return (&/T fixpoints nil))
- ;; (&/try-all% (&/|list (|do [ebound (deref ?eid)]
- ;; (check* fixpoints ebound actual))
- ;; (|do [abound (deref ?aid)]
- ;; (check* fixpoints expected abound))
- ;; (|do [_ (set-var ?eid actual)]
- ;; (return (&/T fixpoints nil)))))
- (|do [ebound (&/try-all% (&/|list (|do [ebound (deref ?eid)]
+ (|do [ebound (&/try-all% (&/|list (|do [ebound (&/try-all% (&/|list (deref ?eid)
+ (fail "##4##")))]
(return (&/V "lux;Some" ebound)))
(return (&/V "lux;None" nil))))
- abound (&/try-all% (&/|list (|do [abound (deref ?aid)]
+ abound (&/try-all% (&/|list (|do [abound (&/try-all% (&/|list (deref ?aid)
+ (fail "##3##")))]
(return (&/V "lux;Some" abound)))
(return (&/V "lux;None" nil))))]
(matchv ::M/objects [ebound abound]
@@ -590,13 +601,9 @@
[["lux;Some" etype] ["lux;None" _]]
(check* fixpoints etype actual)
- ;; (|do [_ (set-var ?aid etype)]
- ;; (return (&/T fixpoints nil)))
[["lux;None" _] ["lux;Some" atype]]
(check* fixpoints expected atype)
- ;; (|do [_ (set-var ?eid atype)]
- ;; (return (&/T fixpoints nil)))
[["lux;Some" etype] ["lux;Some" atype]]
(check* fixpoints etype atype)))
@@ -605,19 +612,17 @@
[["lux;VarT" ?id] _]
(&/try-all% (&/|list (|do [_ (set-var ?id actual)]
(return (&/T fixpoints nil)))
- (|do [bound (deref ?id)]
+ (|do [bound (&/try-all% (&/|list (deref ?id)
+ (fail "##1##")))]
(check* fixpoints bound actual))))
[_ ["lux;VarT" ?id]]
(&/try-all% (&/|list (|do [_ (set-var ?id expected)]
(return (&/T fixpoints nil)))
- (|do [bound (deref ?id)]
+ (|do [bound (&/try-all% (&/|list (deref ?id)
+ (fail "##2##")))]
(check* fixpoints expected bound))))
- ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [F2 A2]]]
- ;; (|do [_ (check* fixpoints F1 F2)
- ;; _ (check* fixpoints A1 A2)]
- ;; (return (&/T fixpoints nil)))
[["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]]
(|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid))
_ (check* fixpoints A1 A2)]
@@ -645,6 +650,11 @@
[fixpoints** _] (check* fixpoints* e* a*)]
(return (&/T fixpoints** nil)))
+ ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [F2 A2]]]
+ ;; (|do [[fixpoints* _] (check* (fp-put fp-pair true fixpoints) F1 F2)
+ ;; [fixpoints** _] (check* fixpoints* A1 A2)]
+ ;; (return (&/T fixpoints** nil)))
+
[["lux;AppT" [F A]] _]
(let [fp-pair (&/T expected actual)
;; _ (prn 'LEFT_APP (&/|length fixpoints))
@@ -714,25 +724,18 @@
(check* fixpoints* eO aO))
[["lux;TupleT" e!members] ["lux;TupleT" a!members]]
- (do ;; (do (prn 'e!members (&/|length e!members))
- ;; (prn 'a!members (&/|length a!members)))
- (if (= (&/|length e!members) (&/|length a!members))
- (|do [fixpoints* (&/fold% (fn [fixp ea]
- (|let [[e a] ea]
- (do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a))
- (|do [[fixp* _] (check* fixp e a)]
- (return fixp*)))))
- fixpoints
- (&/zip2 e!members a!members))
- ;; :let [_ (prn "lux;TupleT" 'DONE)]
- ]
- (return (&/T fixpoints* nil)))
- (do ;; (prn "lux;TupleT" (&/|length e!members) (&/|length a!members))
- ;; (prn "lux;TupleT"
- ;; (&/fold str "" (&/|interpose " " (&/|map show-type e!members)))
- ;; (&/fold str "" (&/|interpose " " (&/|map show-type a!members))))
- ;; (prn "lux;TupleT#fail" (fail "[Type Error] Tuples don't match in size."))
- (fail "[Type Error] Tuples don't match in size."))))
+ (if (= (&/|length e!members) (&/|length a!members))
+ (|do [fixpoints* (&/fold% (fn [fixp ea]
+ (|let [[e a] ea]
+ (do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a))
+ (|do [[fixp* _] (check* fixp e a)]
+ (return fixp*)))))
+ fixpoints
+ (&/zip2 e!members a!members))
+ ;; :let [_ (prn "lux;TupleT" 'DONE)]
+ ]
+ (return (&/T fixpoints* nil)))
+ (fail "[Type Error] Tuples don't match in size."))
[["lux;VariantT" e!cases] ["lux;VariantT" a!cases]]
(if (= (&/|length e!cases) (&/|length a!cases))
@@ -801,12 +804,6 @@
(|do [type* (apply-type ?all ?param)]
(actual-type type*))
- ;; [["lux;AllT" [?env ?self ?arg ?body]]]
- ;; (with-var
- ;; (fn [$var]
- ;; (|do [type* (apply-type type $var)]
- ;; (actual-type type*))))
-
[_]
(return type)
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 16:02:27 +0000