aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux8
-rw-r--r--src/lux/analyser/base.clj2
-rw-r--r--src/lux/analyser/case.clj137
-rw-r--r--src/lux/analyser/lux.clj15
-rw-r--r--src/lux/base.clj16
-rw-r--r--src/lux/compiler/case.clj1
-rw-r--r--src/lux/compiler/type.clj16
-rw-r--r--src/lux/type.clj212
8 files changed, 226 insertions, 181 deletions
diff --git a/source/lux.lux b/source/lux.lux
index d023406f8..91e00d317 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -563,8 +563,8 @@
#Nil]))
_
- (fail "Wrong syntax for def")
- ))))
+ (fail "Wrong syntax for def"))
+ )))
(_lux_declare-macro def'')
(def'' (defmacro tokens)
@@ -680,13 +680,13 @@
#Nil
init
- (#Cons [x xs'])
+ (#Cons x xs')
(foldL f (f init x) xs')))
(def'' (reverse list)
(All' [a]
(->' ($' List (B' a)) ($' List (B' a))))
- (foldL (lambda'' [tail head] (#Cons [head tail]))
+ (foldL (lambda'' [tail head] (#Cons head tail))
#Nil
list))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 218fc6dd9..58c01e642 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -148,4 +148,4 @@
(|do [module* (if (.equals "" ?module)
&/get-module-name
(return ?module))]
- (return (&/ident->text (&/T module* ?name))))))
+ (return (&/T module* ?name)))))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 6cf070a52..6992c11a3 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -13,7 +13,8 @@
[parser :as &parser]
[type :as &type])
(lux.analyser [base :as &&]
- [env :as &env])))
+ [env :as &env]
+ [module :as &module])))
;; [Tags]
(deftags ""
@@ -66,6 +67,7 @@
(defn adjust-type* [up type]
"(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))"
+ ;; (prn 'adjust-type* (&type/show-type type))
(|case type
(&/$AllT _aenv _aname _aarg _abody)
(&type/with-var
@@ -80,45 +82,43 @@
(&type/clean* _avar _abody))))
type
up)]
- (return (&/V &/$TupleT (&/|map (fn [v]
- (&/fold (fn [_abody ena]
- (|let [[_aenv _aname _aarg _avar] ena]
- (&/V &/$AllT (&/T _aenv _aname _aarg _abody))))
- v
- up))
- ?members*))))
-
- (&/$RecordT ?fields)
- (|do [(&/$RecordT ?fields*) (&/fold% (fn [_abody ena]
- (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena]
- (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))]
- (&type/clean* _avar _abody))))
- type
- up)]
- (return (&/V &/$RecordT (&/|map (fn [kv]
- (|let [[k v] kv]
- (&/T k (&/fold (fn [_abody ena]
- (|let [[_aenv _aname _aarg _avar] ena]
- (&/V &/$AllT (&/T _aenv _aname _aarg _abody))))
- v
- up))))
- ?fields*))))
-
- (&/$VariantT ?cases)
- (|do [(&/$VariantT ?cases*) (&/fold% (fn [_abody ena]
- (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena]
- (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))]
- (&type/clean* _avar _abody))))
- type
- up)]
- (return (&/V &/$VariantT (&/|map (fn [kv]
- (|let [[k v] kv]
- (&/T k (&/fold (fn [_abody ena]
- (|let [[_aenv _aname _aarg _avar] ena]
- (&/V &/$AllT (&/T _aenv _aname _aarg _abody))))
- v
- up))))
- ?cases*))))
+ (return (&type/Tuple$ (&/|map (fn [v]
+ (&/fold (fn [_abody ena]
+ (|let [[_aenv _aname _aarg _avar] ena]
+ (&/V &/$AllT (&/T _aenv _aname _aarg _abody))))
+ v
+ up))
+ ?members*))))
+
+ (&/$RecordT ?members)
+ (|do [(&/$RecordT ?members*) (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena]
+ (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))]
+ (&type/clean* _avar _abody))))
+ type
+ up)]
+ (return (&/V &/$RecordT (&/|map (fn [v]
+ (&/fold (fn [_abody ena]
+ (|let [[_aenv _aname _aarg _avar] ena]
+ (&/V &/$AllT (&/T _aenv _aname _aarg _abody))))
+ v
+ up))
+ ?members*))))
+
+ (&/$VariantT ?members)
+ (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena]
+ (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))]
+ (&type/clean* _avar _abody))))
+ type
+ up)]
+ (return (&/V &/$VariantT (&/|map (fn [v]
+ (&/fold (fn [_abody ena]
+ (|let [[_aenv _aname _aarg _avar] ena]
+ (&/V &/$AllT (&/T _aenv _aname _aarg _abody))))
+ v
+ up))
+ ?members*))))
(&/$AppT ?tfun ?targ)
(|do [=type (&type/apply-type ?tfun ?targ)]
@@ -208,7 +208,8 @@
(|let [[sn sv] slot]
(|case sn
(&/$Meta _ (&/$TagS ?ident))
- (|do [=tag (&&/resolved-ident ?ident)]
+ (|do [=ident (&&/resolved-ident ?ident)
+ :let [=tag (&/ident->text =ident)]]
(if-let [=slot-type (&/|get =tag ?slot-types)]
(|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)]
(return (&/T (&/|put =tag =test =tests) =kont)))
@@ -225,23 +226,39 @@
(fail "[Pattern-matching Error] Record requires record-type.")))
(&/$TagS ?ident)
- (|do [=tag (&&/resolved-ident ?ident)
+ (|do [;; :let [_ (println "#00")]
+ [=module =name] (&&/resolved-ident ?ident)
+ ;; :let [_ (println "#01")]
value-type* (adjust-type value-type)
- case-type (&type/variant-case =tag value-type*)
- [=test =kont] (analyse-pattern case-type unit kont)]
- (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont)))
+ ;; :let [_ (println "#02")]
+ idx (&module/tag-index =module =name)
+ ;; :let [_ (println "#03")]
+ case-type (&type/variant-case idx value-type*)
+ ;; :let [_ (println "#04")]
+ [=test =kont] (analyse-pattern case-type unit kont)
+ ;; :let [_ (println "#05")]
+ ]
+ (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont)))
(&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident))
?values))
- (|do [=tag (&&/resolved-ident ?ident)
+ (|do [;; :let [_ (println "#10" ?ident)]
+ [=module =name] (&&/resolved-ident ?ident)
+ ;; :let [_ (println "#11")]
value-type* (adjust-type value-type)
- case-type (&type/variant-case =tag value-type*)
+ ;; :let [_ (println "#12" (&type/show-type value-type*))]
+ idx (&module/tag-index =module =name)
+ ;; :let [_ (println "#13")]
+ case-type (&type/variant-case idx value-type*)
+ ;; :let [_ (println "#14" (&type/show-type case-type))]
[=test =kont] (case (&/|length ?values)
0 (analyse-pattern case-type unit kont)
1 (analyse-pattern case-type (&/|head ?values) kont)
;; 1+
- (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))]
- (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont)))
+ (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))
+ ;; :let [_ (println "#15")]
+ ]
+ (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont)))
)))
(defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns]
@@ -380,13 +397,10 @@
(return true)
(|do [value-type* (resolve-type value-type)]
(|case value-type*
- (&/$RecordT ?fields)
- (|do [totals (&/map% (fn [field]
- (|let [[?tk ?tv] field]
- (if-let [sub-struct (&/|get ?tk ?structs)]
- (check-totality ?tv sub-struct)
- (return false))))
- ?fields)]
+ (&/$RecordT ?members)
+ (|do [totals (&/map2% (fn [sub-struct ?member]
+ (check-totality ?member sub-struct))
+ ?structs ?members)]
(return (&/fold #(and %1 %2) true totals)))
_
@@ -397,13 +411,10 @@
(return true)
(|do [value-type* (resolve-type value-type)]
(|case value-type*
- (&/$VariantT ?cases)
- (|do [totals (&/map% (fn [case]
- (|let [[?tk ?tv] case]
- (if-let [sub-struct (&/|get ?tk ?structs)]
- (check-totality ?tv sub-struct)
- (return false))))
- ?cases)]
+ (&/$VariantT ?members)
+ (|do [totals (&/map2% (fn [sub-struct ?member]
+ (check-totality ?member sub-struct))
+ ?structs ?members)]
(return (&/fold #(and %1 %2) true totals)))
_
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index ba4a173f0..e55d5fec8 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -158,7 +158,8 @@
=slots (&/map% (fn [kv]
(|case kv
[(&/$Meta _ (&/$TagS ?ident)) ?value]
- (|do [?tag (&&/resolved-ident ?ident)
+ (|do [=ident (&&/resolved-ident ?ident)
+ :let [?tag (&/ident->text =ident)]
slot-type (if-let [slot-type (&/|get ?tag types)]
(return slot-type)
(fail (str "[Analyser Error] Record type does not have slot: " ?tag)))
@@ -302,14 +303,14 @@
(|do [loader &/loader]
(|let [[=fn-form =fn-type] =fn]
(|case =fn-form
- (&/$Global ?module ?name)
- (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)]
+ (&&/$var (&/$Global ?module ?name))
+ (|do [[real-name $def] (&&module/find-def ?module ?name)]
(|case $def
(&/$MacroD macro)
- (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))]
+ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))]
macro-expansion #(-> macro (.apply ?args) (.apply %))
- ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))]
- :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)]
+ ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))]
+ ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)]
;; :let [_ (when (or (= "<>" r-name)
;; ;; (= &&/$struct r-name)
;; )
@@ -318,7 +319,7 @@
;; (&/fold str "")
;; (prn (str r-module ";" r-name))))]
]
- (&/flat-map% (partial analyse exo-type) macro-expansion*))
+ (&/flat-map% (partial analyse exo-type) macro-expansion))
_
(|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 73b2bb684..a700a30c8 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -281,13 +281,23 @@
($Cons x xs*)
(V $Cons (T x (|++ xs* ys)))))
+(let [array-class (class (to-array []))]
+ (defn adt->text [adt]
+ (if (= array-class (class adt))
+ (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]")
+ (pr-str adt))))
+
(defn |map [f xs]
(|case xs
($Nil)
xs
($Cons x xs*)
- (V $Cons (T (f x) (|map f xs*)))))
+ (V $Cons (T (f x) (|map f xs*)))
+
+ _
+ (assert false (prn-str '|map f (adt->text xs)))
+ ))
(defn |empty? [xs]
(|case xs
@@ -770,8 +780,8 @@
($Meta _ ($FormS ?elems))
(str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
- _
- (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
+ ;; _
+ ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index e2cbe77a2..b108d463c 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -132,6 +132,7 @@
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/AALOAD)
(.visitLdcInsn ?tag)
+ (&&/wrap-long)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
(.visitJumpInsn Opcodes/IFEQ $else)
(.visitInsn Opcodes/DUP)
diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj
index e9d3014db..3d2ef5070 100644
--- a/src/lux/compiler/type.clj
+++ b/src/lux/compiler/type.clj
@@ -51,23 +51,19 @@
$Nil
(&/|reverse ?members)))
- (&/$VariantT ?cases)
+ (&/$VariantT ?members)
(variant$ &/$VariantT
(&/fold (fn [tail head]
- (|let [[hlabel htype] head]
- (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype)))
- tail)))
+ (Cons$ (->analysis head) tail))
$Nil
- (&/|reverse ?cases)))
+ (&/|reverse ?members)))
- (&/$RecordT ?slots)
+ (&/$RecordT ?members)
(variant$ &/$RecordT
(&/fold (fn [tail head]
- (|let [[hlabel htype] head]
- (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype)))
- tail)))
+ (Cons$ (->analysis head) tail))
$Nil
- (&/|reverse ?slots)))
+ (&/|reverse ?members)))
(&/$LambdaT ?input ?output)
(variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output))))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 553318daf..94b0fbc5e 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -14,7 +14,18 @@
(declare show-type)
-;; [Util]
+;; [Utils]
+(defn |list? [xs]
+ (|case xs
+ (&/$Nil)
+ true
+
+ (&/$Cons x xs*)
+ (|list? xs*)
+
+ _
+ false))
+
(def Bool (&/V &/$DataT "java.lang.Boolean"))
(def Int (&/V &/$DataT "java.lang.Long"))
(def Real (&/V &/$DataT "java.lang.Double"))
@@ -24,79 +35,90 @@
(def $Void (&/V &/$VariantT (&/|list)))
(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil)))
-(defn ^:private Bound$ [name]
+(def ^:private no-env (&/V &/$None nil))
+(defn Data$ [name]
+ (&/V &/$DataT name))
+(defn Bound$ [name]
(&/V &/$BoundT name))
-(defn ^:private Lambda$ [in out]
+(defn Var$ [id]
+ (&/V &/$VarT id))
+(defn Lambda$ [in out]
(&/V &/$LambdaT (&/T in out)))
-(defn ^:private App$ [fun arg]
+(defn App$ [fun arg]
(&/V &/$AppT (&/T fun arg)))
-(defn ^:private Tuple$ [members]
+
+(defn Tuple$ [members]
+ ;; (assert (|list? members))
(&/V &/$TupleT members))
-(defn ^:private Variant$ [members]
+
+(defn Variant$ [members]
+ ;; (assert (|list? members))
(&/V &/$VariantT members))
-(defn ^:private Record$ [members]
+
+(defn Record$ [members]
+ ;; (assert (|list? members))
(&/V &/$RecordT members))
+(defn All$ [env name arg body]
+ (&/V &/$AllT (&/T env name arg body)))
+
(def IO
- (&/V &/$AllT (&/T empty-env "IO" "a"
- (Lambda$ Unit (Bound$ "a")))))
+ (All$ empty-env "IO" "a"
+ (Lambda$ Unit (Bound$ "a"))))
(def List
- (&/V &/$AllT (&/T empty-env "lux;List" "a"
- (Variant$ (&/|list
- ;; lux;Nil
- Unit
- ;; lux;Cons
- (Tuple$ (&/|list (Bound$ "a")
- (App$ (Bound$ "lux;List")
- (Bound$ "a"))))
- )))))
+ (All$ empty-env "lux;List" "a"
+ (Variant$ (&/|list
+ ;; lux;Nil
+ Unit
+ ;; lux;Cons
+ (Tuple$ (&/|list (Bound$ "a")
+ (App$ (Bound$ "lux;List")
+ (Bound$ "a"))))
+ ))))
(def Maybe
- (&/V &/$AllT (&/T empty-env "lux;Maybe" "a"
- (Variant$ (&/|list
- ;; lux;None
- Unit
- ;; lux;Some
- (Bound$ "a")
- )))))
+ (All$ empty-env "lux;Maybe" "a"
+ (Variant$ (&/|list
+ ;; lux;None
+ Unit
+ ;; lux;Some
+ (Bound$ "a")
+ ))))
(def Type
(let [Type (App$ (Bound$ "Type") (Bound$ "_"))
TypeList (App$ List Type)
TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
TypePair (Tuple$ (&/|list Type Type))]
- (App$ (&/V &/$AllT (&/T empty-env "Type" "_"
- (Variant$ (&/|list
- ;; DataT
- Text
- ;; TupleT
- (App$ List Type)
- ;; VariantT
- TypeList
- ;; RecordT
- TypeList
- ;; LambdaT
- TypePair
- ;; BoundT
- Text
- ;; VarT
- Int
- ;; ExT
- Int
- ;; AllT
- (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type))
- ;; AppT
- TypePair
- ))))
+ (App$ (All$ empty-env "Type" "_"
+ (Variant$ (&/|list
+ ;; DataT
+ Text
+ ;; TupleT
+ (App$ List Type)
+ ;; VariantT
+ TypeList
+ ;; RecordT
+ TypeList
+ ;; LambdaT
+ TypePair
+ ;; BoundT
+ Text
+ ;; VarT
+ Int
+ ;; ExT
+ Int
+ ;; AllT
+ (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type))
+ ;; AppT
+ TypePair
+ )))
$Void)))
-(defn fAll [name arg body]
- (&/V &/$AllT (&/T (&/V &/$None nil) name arg body)))
-
(def Bindings
- (fAll "lux;Bindings" "k"
- (fAll "" "v"
+ (All$ empty-env "lux;Bindings" "k"
+ (All$ no-env "" "v"
(Record$ (&/|list
;; "lux;counter"
Int
@@ -108,8 +130,8 @@
(def Env
(let [bindings (App$ (App$ Bindings (Bound$ "k"))
(Bound$ "v"))]
- (fAll "lux;Env" "k"
- (fAll "" "v"
+ (All$ empty-env "lux;Env" "k"
+ (All$ no-env "" "v"
(Record$
(&/|list
;; "lux;name"
@@ -126,8 +148,8 @@
(Tuple$ (&/|list Text Int Int)))
(def Meta
- (fAll &/$Meta "m"
- (fAll "" "v"
+ (All$ empty-env "lux;Meta" "m"
+ (All$ no-env "" "v"
(Variant$ (&/|list
;; &/$Meta
(Tuple$ (&/|list (Bound$ "m")
@@ -140,7 +162,7 @@
(App$ (Bound$ "lux;AST'")
(Bound$ "w")))
AST*List (App$ List AST*)]
- (fAll "lux;AST'" "w"
+ (All$ empty-env "lux;AST'" "w"
(Variant$ (&/|list
;; &/$BoolS
Bool
@@ -171,14 +193,17 @@
(def ^:private ASTList (App$ List AST))
(def Either
- (fAll "lux;Either" "l"
- (fAll "" "r"
- (Variant$ (&/|list (&/T &/$Left (Bound$ "l"))
- (&/T &/$Right (Bound$ "r")))))))
+ (All$ empty-env "lux;Either" "l"
+ (All$ no-env "" "r"
+ (Variant$ (&/|list
+ ;; &/$Left
+ (Bound$ "l")
+ ;; &/$Right
+ (Bound$ "r"))))))
(def StateE
- (fAll "lux;StateE" "s"
- (fAll "" "a"
+ (All$ empty-env "lux;StateE" "s"
+ (All$ no-env "" "a"
(Lambda$ (Bound$ "s")
(App$ (App$ Either Text)
(Tuple$ (&/|list (Bound$ "s")
@@ -193,14 +218,14 @@
(Record$
(&/|list
;; "lux;writer"
- (&/V &/$DataT "org.objectweb.asm.ClassWriter")
+ (Data$ "org.objectweb.asm.ClassWriter")
;; "lux;loader"
- (&/V &/$DataT "java.lang.ClassLoader")
+ (Data$ "java.lang.ClassLoader")
;; "lux;classes"
- (&/V &/$DataT "clojure.lang.Atom"))))
+ (Data$ "clojure.lang.Atom"))))
(def DefData*
- (fAll "lux;DefData'" ""
+ (All$ empty-env "lux;DefData'" ""
(Variant$ (&/|list
;; "lux;TypeD"
Type
@@ -220,20 +245,19 @@
Ident)))
(def $Module
- (fAll "lux;$Module" "Compiler"
+ (All$ empty-env "lux;$Module" "Compiler"
(Record$
(&/|list
;; "lux;module-aliases"
(App$ List (Tuple$ (&/|list Text Text)))
;; "lux;defs"
(App$ List
- (Tuple$
- (&/|list Text
- (Tuple$ (&/|list Bool
- (App$ DefData*
- (Lambda$ ASTList
- (App$ (App$ StateE (Bound$ "Compiler"))
- ASTList))))))))
+ (Tuple$ (&/|list Text
+ (Tuple$ (&/|list Bool
+ (App$ DefData*
+ (Lambda$ ASTList
+ (App$ (App$ StateE (Bound$ "Compiler"))
+ ASTList))))))))
;; "lux;imports"
(App$ List Text)
;; "lux;tags"
@@ -246,15 +270,14 @@
))))
(def $Compiler
- (App$ (fAll "lux;Compiler" ""
+ (App$ (All$ empty-env "lux;Compiler" ""
(Record$
(&/|list
;; "lux;source"
Reader
;; "lux;modules"
- (App$ List (Tuple$
- (&/|list Text
- (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))))
+ (App$ List (Tuple$ (&/|list Text
+ (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))))
;; "lux;envs"
(App$ List
(App$ (App$ Env Text)
@@ -368,13 +391,13 @@
(defn with-var [k]
(|do [id create-var
- output (k (&/V &/$VarT id))
+ output (k (Var$ id))
_ (delete-var id)]
(return output)))
(defn with-vars [amount k]
(|do [=vars (&/map% (constantly create-var) (&/|range amount))
- output (k (&/|map #(&/V &/$VarT %) =vars))
+ output (k (&/|map #(Var$ %) =vars))
_ (&/map% delete-var (&/|reverse =vars))]
(return output)))
@@ -419,7 +442,7 @@
?env*)]
(return (&/V &/$Some clean-env))))
body* (clean* ?tid ?body)]
- (return (&/V &/$AllT (&/T =env ?name ?arg body*))))
+ (return (All$ =env ?name ?arg body*)))
_
(return type)
@@ -608,7 +631,7 @@
(&/$AllT ?local-env ?local-name ?local-arg ?local-def)
(|case ?local-env
(&/$None)
- (&/V &/$AllT (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def))
+ (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def)
(&/$Some _)
type)
@@ -745,11 +768,11 @@
(return* state* output)
(&/$Left _)
- ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid))
+ ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid))
[fixpoints** _] (check* class-loader fixpoints* A1 A2)]
(return (&/T fixpoints** nil)))
state))))
- ;; (|do [_ (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid))
+ ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid))
;; _ (check* class-loader fixpoints A1 A2)]
;; (return (&/T fixpoints nil)))
@@ -762,14 +785,14 @@
(return* state* output)
(&/$Left _)
- ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2)
+ ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2)
e* (apply-type F2 A1)
a* (apply-type F2 A2)
[fixpoints** _] (check* class-loader fixpoints* e* a*)]
(return (&/T fixpoints** nil)))
state)))
;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]]
- ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2)
+ ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2)
;; e* (apply-type F2 A1)
;; a* (apply-type F2 A2)
;; [fixpoints** _] (check* class-loader fixpoints* e* a*)]
@@ -784,14 +807,14 @@
(return* state* output)
(&/$Left _)
- ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id))
+ ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id))
e* (apply-type F1 A1)
a* (apply-type F1 A2)
[fixpoints** _] (check* class-loader fixpoints* e* a*)]
(return (&/T fixpoints** nil)))
state)))
;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]]
- ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id))
+ ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id))
;; e* (apply-type F1 A1)
;; a* (apply-type F1 A2)
;; [fixpoints** _] (check* class-loader fixpoints* e* a*)]
@@ -919,12 +942,15 @@
(return type)
))
-(defn variant-case [case type]
+(defn variant-case [tag type]
(|case type
(&/$VariantT ?cases)
- (if-let [case-type (&/|get case ?cases)]
+ (|case (&/|at tag ?cases)
+ (&/$Some case-type)
(return case-type)
- (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type))))
+
+ (&/$None)
+ (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type))))
_
(fail (str "[Type Error] Type is not a variant: " (show-type type)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 03:59:53 +0000