diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lux/analyser.clj | 2 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 116 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 48 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 42 | ||||
| -rw-r--r-- | src/lux/base.clj | 26 | ||||
| -rw-r--r-- | src/lux/compiler/base.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 20 | ||||
| -rw-r--r-- | src/lux/compiler/type.clj | 32 | ||||
| -rw-r--r-- | src/lux/host.clj | 8 | ||||
| -rw-r--r-- | src/lux/type.clj | 356 |
10 files changed, 335 insertions, 317 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0ad6553bf..f8dd13bd6 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -529,7 +529,7 @@ (fn [?var] (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] (|case [?var ?output-type] - [("lux;VarT" ?e-id) ("lux;VarT" ?a-id)] + [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] (return (&/T ?output-term ?output-type*))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 0bbbde2d7..aaf11ff15 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -21,12 +21,12 @@ (defn ^:private resolve-type [type] (|case type - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (resolve-type type*)) - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -42,64 +42,64 @@ (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" (|case type - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - ("lux;TupleT" ?members) - (|do [("lux;TupleT" ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;TupleT" (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - ("lux;RecordT" ?fields) - (|do [("lux;RecordT" ?fields*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;RecordT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?fields*)))) - - ("lux;VariantT" ?cases) - (|do [("lux;VariantT" ?cases*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;VariantT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?cases*)))) - - ("lux;AppT" ?tfun ?targ) + (&/$TupleT ?members) + (|do [(&/$TupleT ?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 &/$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*)))) + + (&/$AppT ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] (adjust-type* up =type)) - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (adjust-type* up type*)) @@ -153,7 +153,7 @@ (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) (|case value-type* - ("lux;TupleT" ?member-types) + (&/$TupleT ?member-types) (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) @@ -176,7 +176,7 @@ ;; value-type* (resolve-type value-type) ] (|case value-type* - ("lux;RecordT" ?slot-types) + (&/$RecordT ?slot-types) (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] @@ -207,7 +207,7 @@ (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) - ?values)) + ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) @@ -341,7 +341,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) ?structs ?members)] @@ -355,7 +355,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;RecordT" ?fields) + (&/$RecordT ?fields) (|do [totals (&/map% (fn [field] (|let [[?tk ?tv] field] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -372,7 +372,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (|do [totals (&/map% (fn [case] (|let [[?tk ?tv] case] (if-let [sub-struct (&/|get ?tk ?structs)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 06cb5ebfc..ec8b8b5db 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -37,7 +37,7 @@ (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token - [_ ("lux;DataT" _)] + [_ (&/$DataT _)] (return nil) _ @@ -46,16 +46,16 @@ (defn ^:private as-object [type] "(-> Type Type)" (|case type - ("lux;DataT" class) - (&/V "lux;DataT" (&type/as-obj class)) + (&/$DataT class) + (&/V &/$DataT (&type/as-obj class)) _ type)) ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] - (let [input-type (&/V "lux;DataT" <input-class>) - output-type (&/V "lux;DataT" <output-class>)] + (let [input-type (&/V &/$DataT <input-class>) + output-type (&/V &/$DataT <output-class>)] (defn <name> [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) @@ -140,10 +140,10 @@ =classes (&/map% extract-text ?classes) =return (&host/lookup-static-method class-loader ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] - ;; [["lux;DataT" _return-class]] + ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) + (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) =classes ?args) :let [output-type =return] @@ -162,8 +162,8 @@ (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] @@ -179,9 +179,9 @@ =return (if (= "<init>" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] @@ -195,19 +195,19 @@ (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V "lux;DataT" "null")] + (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V "lux;DataT" ?class)] + :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) + (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] @@ -309,11 +309,11 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&/V "lux;DataT" (as-otype itype)) + (&&env/with-local iname (&/V &/$DataT (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V "lux;DataT" (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs (&/|cons (&/T ";this" ?super-class) @@ -356,7 +356,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -370,7 +370,7 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)] + _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) (do-template [<name> <tag>] @@ -386,9 +386,9 @@ ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&/V "lux;DataT" <to-class>)] + (let [output-type (&/V &/$DataT <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V <tag> =value) output-type)))))) @@ -413,9 +413,9 @@ ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&/V "lux;DataT" <to-class>)] + (let [output-type (&/V &/$DataT <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V <tag> =value) output-type)))))) @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) _ (compile-token (&/V "jvm-program" =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index ac7e56ef4..6503fe2ea 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -37,14 +37,14 @@ (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -73,7 +73,7 @@ (defn analyse-variant [analyse exo-type ident ?values] (|do [exo-type* (|case exo-type - ("lux;VarT" ?id) + (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) (|do [_ (&type/set-var ?id &type/Type)] @@ -82,7 +82,7 @@ _ (&type/actual-type exo-type))] (|case exo-type* - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] @@ -90,7 +90,7 @@ exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -101,11 +101,11 @@ (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (|case exo-type - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - ("lux;AllT" _) + (&/$AllT _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -117,7 +117,7 @@ _ (&type/actual-type exo-type)) types (|case exo-type* - ("lux;RecordT" ?table) + (&/$RecordT ?table) (return ?table) _ @@ -139,7 +139,7 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] - (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) + (return (&/|list (&/T (&/V "record" =slots) (&/V &/$RecordT exo-type)))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -238,7 +238,7 @@ (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -247,21 +247,21 @@ (|do [type* (&type/apply-type ?fun-type* $var) [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] (|case $var - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) - ("lux;LambdaT" ?input-t ?output-t) + (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) - ;; [["lux;VarT" ?id-t]] + ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) _ @@ -314,7 +314,7 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -323,7 +323,7 @@ ;; exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - ("lux;LambdaT" ?arg-t ?return-t) + (&/$LambdaT ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] @@ -335,26 +335,26 @@ (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type - ("lux;AllT" _env _self _arg _body) + (&/$AllT _env _self _arg _body) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] (|case $var - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id) ;; dtype* (&type/actual-type dtype) ] (|case dtype - ("lux;BoundT" ?vname) + (&/$BoundT ?vname) (return (&/T _expr exo-type)) - ("lux;ExT" _) + (&/$ExT _) (return (&/T _expr exo-type)) - ("lux;VarT" ?_id) + (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? diff --git a/src/lux/base.clj b/src/lux/base.clj index 7ec9e3029..532f56695 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,17 +12,22 @@ clojure.core.match.array)) ;; [Tags] +;; List (def $Nil "lux;Nil") (def $Cons "lux;Cons") +;; Maybe (def $None "lux;None") (def $Some "lux;Some") +;; Meta (def $Meta "lux;Meta") +;; Either (def $Left "lux;Left") (def $Right "lux;Right") +;; AST (def $BoolS "lux;BoolS") (def $IntS "lux;IntS") (def $RealS "lux;RealS") @@ -34,6 +39,18 @@ (def $TupleS "lux;TupleS") (def $RecordS "lux;RecordS") +;; Type +(def $DataT "lux;DataT") +(def $TupleT "lux;TupleT") +(def $VariantT "lux;VariantT") +(def $RecordT "lux;RecordT") +(def $LambdaT "lux;LambdaT") +(def $VarT "lux;VarT") +(def $ExT "lux;ExT") +(def $BoundT "lux;BoundT") +(def $AppT "lux;AppT") +(def $AllT "lux;AllT") + ;; [Fields] ;; Binding (def $COUNTER 0) @@ -156,8 +173,9 @@ (V $Cons (T (T slot value) table*)) (V $Cons (T (T k v) (|put slot value table*)))) - _ - (assert false (prn-str '|put (aget table 0))))) + ;; _ + ;; (assert false (prn-str '|put (aget table 0))) + )) (defn |remove [slot table] (|case table @@ -541,7 +559,7 @@ ;; "lux;eval?" false ;; "lux;expected" - (V "lux;VariantT" (|list)) + (V $VariantT (|list)) ;; "lux;host" (host nil) ;; "lux;modules" @@ -677,7 +695,7 @@ _ output)))) -(defn with-cursor [cursor body] +(defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" (if (= "" (aget cursor 0)) body diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 74e5625b3..03fae9fec 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -50,7 +50,7 @@ (write-file (str module-dir "/" name ".class") data))) ;; [Exports] -(defn load-class! [^ClassLoader loader name] +(defn ^Class load-class! [^ClassLoader loader name] ;; (prn 'load-class! name) (.loadClass loader name)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 02e9e1430..78b9e72f6 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,34 +52,34 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - ("lux;TupleT" (&/$Nil)) + (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) - ("lux;DataT" "boolean") + (&/$DataT "boolean") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - ("lux;DataT" "byte") + (&/$DataT "byte") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - ("lux;DataT" "short") + (&/$DataT "short") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - ("lux;DataT" "int") + (&/$DataT "int") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - ("lux;DataT" "long") + (&/$DataT "long") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - ("lux;DataT" "float") + (&/$DataT "float") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - ("lux;DataT" "double") + (&/$DataT "double") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - ("lux;DataT" "char") + (&/$DataT "char") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - ("lux;DataT" _) + (&/$DataT _) nil) *writer*)) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 6f785905a..46e6ec2d9 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -40,18 +40,18 @@ (defn ->analysis [type] "(-> Type Analysis)" (|case type - ("lux;DataT" ?class) - (variant$ "lux;DataT" (text$ ?class)) + (&/$DataT ?class) + (variant$ &/$DataT (text$ ?class)) - ("lux;TupleT" ?members) - (variant$ "lux;TupleT" + (&/$TupleT ?members) + (variant$ &/$TupleT (&/fold (fn [tail head] (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?members))) - ("lux;VariantT" ?cases) - (variant$ "lux;VariantT" + (&/$VariantT ?cases) + (variant$ &/$VariantT (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) @@ -59,8 +59,8 @@ $Nil (&/|reverse ?cases))) - ("lux;RecordT" ?slots) - (variant$ "lux;RecordT" + (&/$RecordT ?slots) + (variant$ &/$RecordT (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) @@ -68,11 +68,11 @@ $Nil (&/|reverse ?slots))) - ("lux;LambdaT" ?input ?output) - (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + (&/$LambdaT ?input ?output) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - ("lux;AllT" ?env ?name ?arg ?body) - (variant$ "lux;AllT" + (&/$AllT ?env ?name ?arg ?body) + (variant$ &/$AllT (tuple$ (&/|list (|case ?env (&/$None) (variant$ &/$None (tuple$ (&/|list))) @@ -89,9 +89,9 @@ (text$ ?arg) (->analysis ?body)))) - ("lux;BoundT" ?name) - (variant$ "lux;BoundT" (text$ ?name)) + (&/$BoundT ?name) + (variant$ &/$BoundT (text$ ?name)) - ("lux;AppT" ?fun ?arg) - (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (&/$AppT ?fun ?arg) + (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 3f1ffb25a..8ffe77b96 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,7 +29,7 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) ))) @@ -69,13 +69,13 @@ (defn ->java-sig [^objects type] (|case type - ("lux;DataT" ?name) + (&/$DataT ?name) (->type-signature ?name) - ("lux;LambdaT" _ _) + (&/$LambdaT _ _) (->type-signature function-class) - ("lux;TupleT" (&/$Nil)) + (&/$TupleT (&/$Nil)) "V" )) diff --git a/src/lux/type.clj b/src/lux/type.clj index 45c1f2247..0a80d4fbc 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -15,65 +15,65 @@ (declare show-type) ;; [Util] -(def Bool (&/V "lux;DataT" "java.lang.Boolean")) -(def Int (&/V "lux;DataT" "java.lang.Long")) -(def Real (&/V "lux;DataT" "java.lang.Double")) -(def Char (&/V "lux;DataT" "java.lang.Character")) -(def Text (&/V "lux;DataT" "java.lang.String")) -(def Unit (&/V "lux;TupleT" (&/|list))) -(def $Void (&/V "lux;VariantT" (&/|list))) +(def Bool (&/V &/$DataT "java.lang.Boolean")) +(def Int (&/V &/$DataT "java.lang.Long")) +(def Real (&/V &/$DataT "java.lang.Double")) +(def Char (&/V &/$DataT "java.lang.Character")) +(def Text (&/V &/$DataT "java.lang.String")) +(def Unit (&/V &/$TupleT (&/|list))) +(def $Void (&/V &/$VariantT (&/|list))) (def IO - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" - (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" + (&/V &/$LambdaT (&/T Unit (&/V &/$BoundT "a")))))) (def List - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" - (&/V "lux;VariantT" (&/|list (&/T &/$Nil Unit) - (&/T &/$Cons (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") - (&/V "lux;BoundT" "a"))))))))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" + (&/V &/$VariantT (&/|list (&/T &/$Nil Unit) + (&/T &/$Cons (&/V &/$TupleT (&/|list (&/V &/$BoundT "a") + (&/V &/$AppT (&/T (&/V &/$BoundT "lux;List") + (&/V &/$BoundT "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" - (&/V "lux;VariantT" (&/|list (&/T &/$None Unit) - (&/T &/$Some (&/V "lux;BoundT" "a"))))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" + (&/V &/$VariantT (&/|list (&/T &/$None Unit) + (&/T &/$Some (&/V &/$BoundT "a"))))))) (def Type - (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) - TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) - TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" - (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) - (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) - (&/T "lux;VariantT" TypeEnv) - (&/T "lux;RecordT" TypeEnv) - (&/T "lux;LambdaT" TypePair) - (&/T "lux;BoundT" Text) - (&/T "lux;VarT" Int) - (&/T "lux;AllT" (&/V "lux;TupleT" (&/|list (&/V "lux;AppT" (&/T Maybe TypeEnv)) Text Text Type))) - (&/T "lux;AppT" TypePair) - (&/T "lux;ExT" Int) + (let [Type (&/V &/$AppT (&/T (&/V &/$BoundT "Type") (&/V &/$BoundT "_"))) + TypeEnv (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Type)))) + TypePair (&/V &/$TupleT (&/|list Type Type))] + (&/V &/$AppT (&/T (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" + (&/V &/$VariantT (&/|list (&/T &/$DataT Text) + (&/T &/$TupleT (&/V &/$AppT (&/T List Type))) + (&/T &/$VariantT TypeEnv) + (&/T &/$RecordT TypeEnv) + (&/T &/$LambdaT TypePair) + (&/T &/$BoundT Text) + (&/T &/$VarT Int) + (&/T &/$AllT (&/V &/$TupleT (&/|list (&/V &/$AppT (&/T Maybe TypeEnv)) Text Text Type))) + (&/T &/$AppT TypePair) + (&/T &/$ExT Int) )))) $Void)))) (defn fAll [name arg body] - (&/V "lux;AllT" (&/T (&/V &/$None nil) name arg body))) + (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) (def Bindings (fAll "lux;Bindings" "k" (fAll "" "v" - (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int) - (&/T "lux;mappings" (&/V "lux;AppT" (&/T List - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "k") - (&/V "lux;BoundT" "v"))))))))))) + (&/V &/$RecordT (&/|list (&/T "lux;counter" Int) + (&/T "lux;mappings" (&/V &/$AppT (&/T List + (&/V &/$TupleT (&/|list (&/V &/$BoundT "k") + (&/V &/$BoundT "v"))))))))))) (def Env - (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k"))) - (&/V "lux;BoundT" "v")))] + (let [bindings (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings (&/V &/$BoundT "k"))) + (&/V &/$BoundT "v")))] (fAll "lux;Env" "k" (fAll "" "v" - (&/V "lux;RecordT" + (&/V &/$RecordT (&/|list (&/T "lux;name" Text) (&/T "lux;inner-closures" Int) (&/T "lux;locals" bindings) @@ -81,23 +81,23 @@ )))))) (def Cursor - (&/V "lux;TupleT" (&/|list Text Int Int))) + (&/V &/$TupleT (&/|list Text Int Int))) (def Meta (fAll &/$Meta "m" (fAll "" "v" - (&/V "lux;VariantT" (&/|list (&/T &/$Meta (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") - (&/V "lux;BoundT" "v"))))))))) + (&/V &/$VariantT (&/|list (&/T &/$Meta (&/V &/$TupleT (&/|list (&/V &/$BoundT "m") + (&/V &/$BoundT "v"))))))))) -(def Ident (&/V "lux;TupleT" (&/|list Text Text))) +(def Ident (&/V &/$TupleT (&/|list Text Text))) (def AST* - (let [AST* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;AST'") - (&/V "lux;BoundT" "w"))))) - AST*List (&/V "lux;AppT" (&/T List AST*))] + (let [AST* (&/V &/$AppT (&/T (&/V &/$BoundT "w") + (&/V &/$AppT (&/T (&/V &/$BoundT "lux;AST'") + (&/V &/$BoundT "w"))))) + AST*List (&/V &/$AppT (&/T List AST*))] (fAll "lux;AST'" "w" - (&/V "lux;VariantT" (&/|list (&/T &/$BoolS Bool) + (&/V &/$VariantT (&/|list (&/T &/$BoolS Bool) (&/T &/$IntS Int) (&/T &/$RealS Real) (&/T &/$CharS Char) @@ -106,75 +106,75 @@ (&/T &/$TagS Ident) (&/T &/$FormS AST*List) (&/T &/$TupleS AST*List) - (&/T &/$RecordS (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) + (&/T &/$RecordS (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list AST* AST*)))))) )))) (def AST - (let [w (&/V "lux;AppT" (&/T Meta Cursor))] - (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T AST* w)))))) + (let [w (&/V &/$AppT (&/T Meta Cursor))] + (&/V &/$AppT (&/T w (&/V &/$AppT (&/T AST* w)))))) -(def ^:private ASTList (&/V "lux;AppT" (&/T List AST))) +(def ^:private ASTList (&/V &/$AppT (&/T List AST))) (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V "lux;VariantT" (&/|list (&/T &/$Left (&/V "lux;BoundT" "l")) - (&/T &/$Right (&/V "lux;BoundT" "r"))))))) + (&/V &/$VariantT (&/|list (&/T &/$Left (&/V &/$BoundT "l")) + (&/T &/$Right (&/V &/$BoundT "r"))))))) (def StateE (fAll "lux;StateE" "s" (fAll "" "a" - (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s") - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text)) - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "s") - (&/V "lux;BoundT" "a")))))))))) + (&/V &/$LambdaT (&/T (&/V &/$BoundT "s") + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Either Text)) + (&/V &/$TupleT (&/|list (&/V &/$BoundT "s") + (&/V &/$BoundT "a")))))))))) (def Reader - (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Meta Cursor)) + (&/V &/$AppT (&/T List + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Meta Cursor)) Text))))) (def HostState - (&/V "lux;RecordT" - (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter")) - (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader")) - (&/T "lux;classes" (&/V "lux;DataT" "clojure.lang.Atom"))))) + (&/V &/$RecordT + (&/|list (&/T "lux;writer" (&/V &/$DataT "org.objectweb.asm.ClassWriter")) + (&/T "lux;loader" (&/V &/$DataT "java.lang.ClassLoader")) + (&/T "lux;classes" (&/V &/$DataT "clojure.lang.Atom"))))) (def DefData* (fAll "lux;DefData'" "" - (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Type) - (&/T "lux;ValueD" (&/V "lux;TupleT" (&/|list Type Unit))) - (&/T "lux;MacroD" (&/V "lux;BoundT" "")) + (&/V &/$VariantT (&/|list (&/T "lux;TypeD" Type) + (&/T "lux;ValueD" (&/V &/$TupleT (&/|list Type Unit))) + (&/T "lux;MacroD" (&/V &/$BoundT "")) (&/T "lux;AliasD" Ident))))) (def LuxVar - (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) + (&/V &/$VariantT (&/|list (&/T "lux;Local" Int) (&/T "lux;Global" Ident)))) (def $Module (fAll "lux;$Module" "Compiler" - (&/V "lux;RecordT" - (&/|list (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) - (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/V &/$RecordT + (&/|list (&/T "lux;module-aliases" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Text))))) + (&/T "lux;defs" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text - (&/V "lux;TupleT" (&/|list Bool - (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T ASTList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) + (&/V &/$TupleT (&/|list Bool + (&/V &/$AppT (&/T DefData* + (&/V &/$LambdaT (&/T ASTList + (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE (&/V &/$BoundT "Compiler"))) ASTList))))))))))))) - (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) + (&/T "lux;imports" (&/V &/$AppT (&/T List Text))))))) (def $Compiler - (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" - (&/V "lux;RecordT" + (&/V &/$AppT (&/T (fAll "lux;Compiler" "" + (&/V &/$RecordT (&/|list (&/T "lux;source" Reader) - (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/T "lux;modules" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text - (&/V "lux;AppT" (&/T $Module (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" "")))))))))) - (&/T "lux;envs" (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text)) - (&/V "lux;TupleT" (&/|list LuxVar Type))))))) - (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) + (&/V &/$AppT (&/T $Module (&/V &/$AppT (&/T (&/V &/$BoundT "lux;Compiler") (&/V &/$BoundT "")))))))))) + (&/T "lux;envs" (&/V &/$AppT (&/T List + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Env Text)) + (&/V &/$TupleT (&/|list LuxVar Type))))))) + (&/T "lux;types" (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) (&/T "lux;seed" Int) (&/T "lux;eval?" Bool) @@ -184,8 +184,8 @@ $Void))) (def Macro - (&/V "lux;LambdaT" (&/T ASTList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) + (&/V &/$LambdaT (&/T ASTList + (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE $Compiler)) ASTList))))) (defn bound? [id] @@ -237,7 +237,7 @@ (def existential (|do [seed &/gen-id] - (return (&/V "lux;ExT" seed)))) + (return (&/V &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -257,7 +257,7 @@ (&/$Some ?type*) (|case ?type* - ("lux;VarT" ?id*) + (&/$VarT ?id*) (if (.equals ^Object id ?id*) (return (&/T ?id (&/V &/$None nil))) (return binding)) @@ -277,52 +277,52 @@ (defn with-var [k] (|do [id create-var - output (k (&/V "lux;VarT" id)) + output (k (&/V &/$VarT id)) _ (delete-var id)] (return output))) (defn with-vars [amount k] (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(&/V "lux;VarT" %) =vars)) + output (k (&/|map #(&/V &/$VarT %) =vars)) _ (&/map% delete-var (&/|reverse =vars))] (return output))) (defn clean* [?tid type] (|case type - ("lux;VarT" ?id) + (&/$VarT ?id) (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) - ("lux;LambdaT" ?arg ?return) + (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (&/V "lux;LambdaT" (&/T =arg =return)))) + (return (&/V &/$LambdaT (&/T =arg =return)))) - ("lux;AppT" ?lambda ?param) + (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (&/V "lux;AppT" (&/T =lambda =param)))) + (return (&/V &/$AppT (&/T =lambda =param)))) - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (&/V "lux;TupleT" =members))) + (return (&/V &/$TupleT =members))) - ("lux;VariantT" ?members) + (&/$VariantT ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] - (return (&/V "lux;VariantT" =members))) + (return (&/V &/$VariantT =members))) - ("lux;RecordT" ?members) + (&/$RecordT ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] - (return (&/V "lux;RecordT" =members))) + (return (&/V &/$RecordT =members))) - ("lux;AllT" ?env ?name ?arg ?body) + (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env (&/$None) (return ?env) @@ -334,7 +334,7 @@ ?env*)] (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] - (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) + (return (&/V &/$AllT (&/T =env ?name ?arg body*)))) _ (return type) @@ -342,7 +342,7 @@ (defn clean [tvar type] (|case tvar - ("lux;VarT" ?id) + (&/$VarT ?id) (clean* ?id type) _ @@ -350,7 +350,7 @@ (defn ^:private unravel-fun [type] (|case type - ("lux;LambdaT" ?in ?out) + (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] (&/T ??out (&/|cons ?in ?args))) @@ -359,7 +359,7 @@ (defn ^:private unravel-app [fun-type] (|case fun-type - ("lux;AppT" ?left ?right) + (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) @@ -368,21 +368,21 @@ (defn show-type [^objects type] (|case type - ("lux;DataT" name) + (&/$DataT name) (str "(^ " name ")") - ("lux;TupleT" elems) + (&/$TupleT elems) (if (&/|empty? elems) "(,)" (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - ("lux;VariantT" cases) + (&/$VariantT cases) (if (&/|empty? cases) "(|)" (str "(| " (->> cases (&/|map (fn [kv] (|case kv - [k ("lux;TupleT" (&/$Nil))] + [k (&/$TupleT (&/$Nil))] (str "#" k) [k v] @@ -391,7 +391,7 @@ (&/fold str "")) ")")) - ("lux;RecordT" fields) + (&/$RecordT fields) (str "(& " (->> fields (&/|map (fn [kv] (|case kv @@ -400,29 +400,29 @@ (&/|interpose " ") (&/fold str "")) ")") - ("lux;LambdaT" input output) + (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - ("lux;VarT" id) + (&/$VarT id) (str "⌈" id "⌋") - ("lux;ExT" ?id) + (&/$ExT ?id) (str "⟨" ?id "⟩") - ("lux;BoundT" name) + (&/$BoundT name) name - ("lux;AppT" _ _) + (&/$AppT _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - ("lux;AllT" ?env ?name ?arg ?body) + (&/$AllT ?env ?name ?arg ?body) (if (= "" ?name) (let [[args body] (loop [args (list ?arg) body* ?body] (|case body* - ("lux;AllT" ?env* ?name* ?arg* ?body*) + (&/$AllT ?env* ?name* ?arg* ?body*) (recur (cons ?arg* args) ?body*) _ @@ -434,16 +434,16 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] - [("lux;DataT" xname) ("lux;DataT" yname)] + [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [("lux;TupleT" xelems) ("lux;TupleT" yelems)] + [(&/$TupleT xelems) (&/$TupleT yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) - [("lux;VariantT" xcases) ("lux;VariantT" ycases)] + [(&/$VariantT xcases) (&/$VariantT ycases)] (&/fold2 (fn [old xcase ycase] (|let [[xname xtype] xcase [yname ytype] ycase] @@ -451,7 +451,7 @@ true xcases ycases) - [("lux;RecordT" xslots) ("lux;RecordT" yslots)] + [(&/$RecordT xslots) (&/$RecordT yslots)] (&/fold2 (fn [old xslot yslot] (|let [[xname xtype] xslot [yname ytype] yslot] @@ -459,23 +459,23 @@ true xslots yslots) - [("lux;LambdaT" xinput xoutput) ("lux;LambdaT" yinput youtput)] + [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) - [("lux;VarT" xid) ("lux;VarT" yid)] + [(&/$VarT xid) (&/$VarT yid)] (.equals ^Object xid yid) - [("lux;BoundT" xname) ("lux;BoundT" yname)] + [(&/$BoundT xname) (&/$BoundT yname)] (.equals ^Object xname yname) - [("lux;ExT" xid) ("lux;ExT" yid)] + [(&/$ExT xid) (&/$ExT yid)] (.equals ^Object xid yid) - [("lux;AppT" xlambda xparam) ("lux;AppT" ylambda yparam)] + [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [("lux;AllT" xenv xname xarg xbody) ("lux;AllT" yenv yname yarg ybody)] + [(&/$AllT xenv xname xarg xbody) (&/$AllT yenv yname yarg ybody)] (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] @@ -522,36 +522,36 @@ (defn beta-reduce [env type] (|case type - ("lux;VariantT" ?cases) - (&/V "lux;VariantT" (&/|map (fn [kv] + (&/$VariantT ?cases) + (&/V &/$VariantT (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?cases)) - ("lux;RecordT" ?fields) - (&/V "lux;RecordT" (&/|map (fn [kv] + (&/$RecordT ?fields) + (&/V &/$RecordT (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?fields)) - ("lux;TupleT" ?members) - (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members)) + (&/$TupleT ?members) + (&/V &/$TupleT (&/|map (partial beta-reduce env) ?members)) - ("lux;AppT" ?type-fn ?type-arg) - (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) + (&/$AppT ?type-fn ?type-arg) + (&/V &/$AppT (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) - ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) + (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (&/V "lux;AllT" (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) + (&/V &/$AllT (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) (&/$Some _) type) - ("lux;LambdaT" ?input ?output) - (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output))) + (&/$LambdaT ?input ?output) + (&/V &/$LambdaT (&/T (beta-reduce env ?input) (beta-reduce env ?output))) - ("lux;BoundT" ?name) + (&/$BoundT ?name) (if-let [bound (&/|get ?name env)] (beta-reduce env bound) type) @@ -562,7 +562,7 @@ (defn apply-type [type-fn param] (|case type-fn - ("lux;AllT" local-env local-name local-arg local-def) + (&/$AllT local-env local-name local-arg local-def) (let [local-env* (|case local-env (&/$None) (&/|table) @@ -574,7 +574,7 @@ (&/|put local-arg param)) local-def))) - ("lux;AppT" F A) + (&/$AppT F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -602,7 +602,7 @@ (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) (|case [expected actual] - [("lux;VarT" ?eid) ("lux;VarT" ?aid)] + [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/T fixpoints nil)) (|do [ebound (fn [state] @@ -633,7 +633,7 @@ [(&/$Some etype) (&/$Some atype)] (check* class-loader fixpoints etype atype)))) - [("lux;VarT" ?id) _] + [(&/$VarT ?id) _] (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) @@ -644,7 +644,7 @@ (check* class-loader fixpoints bound actual)) state))) - [_ ("lux;VarT" ?id)] + [_ (&/$VarT ?id)] (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) @@ -655,18 +655,18 @@ (check* class-loader fixpoints expected bound)) state))) - [("lux;AppT" ("lux;VarT" ?eid) A1) ("lux;AppT" ("lux;VarT" ?aid) A2)] + [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) (&/V &/$AppT (&/T F2 A2)))) state)] (&/$Right state* output) (return* state* output) (&/$Left _) - ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + ((check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual) state)))) state) (&/$Right state* output) @@ -674,65 +674,65 @@ (&/$Left _) (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) state)))) - ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; (|do [_ (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) - [("lux;AppT" ("lux;VarT" ?id) A1) ("lux;AppT" F2 A2)] + [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual)) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [("lux;AppT" F1 A1) ("lux;AppT" ("lux;VarT" ?id) A2)] + [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [("lux;AppT" F A) _] + [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) @@ -753,28 +753,28 @@ (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) - [_ ("lux;AppT" F A)] + [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [("lux;AllT" _) _] + [(&/$AllT _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ ("lux;AllT" _)] + [_ (&/$AllT _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints expected actual*)))) - [("lux;DataT" e!name) ("lux;DataT" "null")] + [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) - [["lux;DataT" e!name] ["lux;DataT" a!name]] + [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) @@ -782,11 +782,11 @@ (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - [("lux;LambdaT" eI eO) ("lux;LambdaT" aI aO)] + [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [("lux;TupleT" e!members) ("lux;TupleT" a!members)] + [(&/$TupleT e!members) (&/$TupleT a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) @@ -794,7 +794,7 @@ e!members a!members)] (return (&/T fixpoints* nil))) - [("lux;VariantT" e!cases) ("lux;VariantT" a!cases)] + [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] (|let [[e!name e!type] e!case [a!name a!type] a!case] @@ -806,7 +806,7 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [("lux;RecordT" e!slots) ("lux;RecordT" a!slots)] + [(&/$RecordT e!slots) (&/$RecordT a!slots)] (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] (|let [[e!name e!type] e!slot [a!name a!type] a!slot] @@ -818,7 +818,7 @@ e!slots a!slots)] (return (&/T fixpoints* nil))) - [("lux;ExT" e!id) ("lux;ExT" a!id)] + [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -834,11 +834,11 @@ (defn apply-lambda [func param] (|case func - ("lux;LambdaT" input output) + (&/$LambdaT input output) (|do [_ (check* init-fixpoints input param)] (return output)) - ("lux;AllT" _) + (&/$AllT _) (with-var (fn [$var] (|do [func* (apply-type func $var) @@ -851,11 +851,11 @@ (defn actual-type [type] (|case type - ("lux;AppT" ?all ?param) + (&/$AppT ?all ?param) (|do [type* (apply-type ?all ?param)] (actual-type type*)) - ("lux;VarT" ?id) + (&/$VarT ?id) (deref ?id) _ @@ -864,7 +864,7 @@ (defn variant-case [case type] (|case type - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (if-let [case-type (&/|get case ?cases)] (return case-type) (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) |