From 72a9ed29ca5518ca98658873f4616d5637db80af Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Aug 2015 23:55:56 -0400 Subject: - Changing tags so they're actually indices (part 2). - Fixed some bugs. - Now pattern-matching on variants works with indices, rather than text tags. --- src/lux/analyser/base.clj | 2 +- src/lux/analyser/case.clj | 137 ++++++++++++++++-------------- src/lux/analyser/lux.clj | 15 ++-- src/lux/base.clj | 16 +++- src/lux/compiler/case.clj | 1 + src/lux/compiler/type.clj | 16 ++-- src/lux/type.clj | 212 ++++++++++++++++++++++++++-------------------- 7 files changed, 222 insertions(+), 177 deletions(-) (limited to 'src') 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))))) -- cgit v1.2.3