diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 38 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 1 | ||||
| -rw-r--r-- | src/lux/analyser/env.clj | 2 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 84 | ||||
| -rw-r--r-- | src/lux/analyser/module.clj | 47 | ||||
| -rw-r--r-- | src/lux/base.clj | 98 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 4 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 15 | ||||
| -rw-r--r-- | src/lux/type.clj | 409 |
9 files changed, 462 insertions, 236 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0e58f530b..7810c415b 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -17,7 +17,8 @@ [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [host :as &&host]))) + [host :as &&host] + [module :as &&module]))) ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] @@ -37,6 +38,14 @@ _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) +(defn ^:private parse-tag [ast] + (|case ast + (&/$Meta _ (&/$TagS "" name)) + (return name) + + _ + (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) + (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays @@ -431,6 +440,12 @@ (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) + (&/$Cons (&/$Meta _ (&/$TupleS tags)) + (&/$Nil)))) + (|do [tags* (&/map% parse-tag tags)] + (&&lux/analyse-declare-tags tags*)) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) (&/$Cons (&/$Meta _ (&/$TextS ?path)) (&/$Nil)))) @@ -492,7 +507,9 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) + (|do [[module tag-name] (&/normalize ?ident) + idx (&&module/tag-index module tag-name)] + (&&lux/analyse-variant analyse exo-type idx (&/|list))) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) @@ -512,7 +529,10 @@ (|case token (&/$Meta meta ?token) (fn [state] - (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn e) + (assert false (prn-str 'analyse-basic-ast (&/show-ast ?token))))) (&/$Right state* output) (return* state* output) @@ -540,11 +560,21 @@ )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] + ;; (prn 'analyse-ast (&/show-ast token)) (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type (|case token + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) (fn [state] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 3484e869d..218fc6dd9 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -28,6 +28,7 @@ "ann" "def" "declare-macro" + "var" "captured" "jvm-getstatic" diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 2f35218d8..614b38799 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -24,7 +24,7 @@ (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) =return (body (&/update$ &/$ENVS (fn [stack] - (let [bound-unit (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER inc) (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 45177ce46..ba4a173f0 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -71,7 +71,7 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) -(defn analyse-variant [analyse exo-type ident ?values] +(defn analyse-variant [analyse exo-type idx ?values] (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -83,21 +83,50 @@ (&type/actual-type exo-type))] (|case exo-type* (&/$VariantT ?cases) - (|do [?tag (&&/resolved-ident ident)] - (if-let [vtype (&/|get ?tag ?cases)] - (|do [=value (analyse-variant-body analyse vtype ?values)] - (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) - exo-type)))) - (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (analyse-variant-body analyse vtype ?values)] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** ident ?values)))) + (analyse-variant analyse exo-type** idx ?values)))) _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) +;; (defn analyse-variant [analyse exo-type ident ?values] +;; (|do [exo-type* (|case exo-type +;; (&/$VarT ?id) +;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] +;; (&type/actual-type exo-type*)) +;; (|do [_ (&type/set-var ?id &type/Type)] +;; (&type/actual-type &type/Type)))) + +;; _ +;; (&type/actual-type exo-type))] +;; (|case exo-type* +;; (&/$VariantT ?cases) +;; (|do [?tag (&&/resolved-ident ident)] +;; (if-let [vtype (&/|get ?tag ?cases)] +;; (|do [=value (analyse-variant-body analyse vtype ?values)] +;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) +;; exo-type)))) +;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + +;; (&/$AllT _) +;; (&type/with-var +;; (fn [$var] +;; (|do [exo-type** (&type/apply-type exo-type* $var)] +;; (analyse-variant analyse exo-type** ident ?values)))) + +;; _ +;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (|case exo-type @@ -158,7 +187,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] @@ -194,7 +223,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type)))) state) @@ -397,14 +426,39 @@ _ (do (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))] + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]] (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] - (|do [module-name &/get-module-name] - (|do [_ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] - (return (&/|list))))) + (|do [module-name &/get-module-name + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] + (return (&/|list)))) + +(defn ensure-undeclared-tags [module tags] + (|do [;; :let [_ (prn 'ensure-undeclared-tags/_0)] + tags-table (&&module/tags-by-module module) + ;; :let [_ (prn 'ensure-undeclared-tags/_1)] + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (return nil))) + tags) + ;; :let [_ (prn 'ensure-undeclared-tags/_2)] + ] + (return nil))) + +(defn analyse-declare-tags [tags] + (|do [;; :let [_ (prn 'analyse-declare-tags/_0)] + module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-tags/_1)] + _ (ensure-undeclared-tags module-name tags) + ;; :let [_ (prn 'analyse-declare-tags/_2)] + _ (&&module/declare-tags module-name tags) + ;; :let [_ (prn 'analyse-declare-tags/_3)] + ] + (return (&/|list)))) (defn analyse-import [analyse compile-module compile-token ?path] (|do [module-name &/get-module-name @@ -440,6 +494,6 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value)] + =value (analyse-1+ analyse ?value)] (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 35ae7e5b7..68554a019 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -18,14 +18,17 @@ ;; [Utils] (def ^:private $DEFS 0) -(def ^:private $ALIASES 1) -(def ^:private $IMPORTS 2) +(def ^:private $IMPORTS 1) +(def ^:private $ALIASES 2) +(def ^:private $tags 3) (def ^:private +init+ (&/R ;; "lux;defs" (&/|table) + ;; "lux;imports" + (&/|list) ;; "lux;module-aliases" (&/|table) - ;; "lux;imports" + ;; "lux;tags" (&/|list) )) @@ -235,12 +238,50 @@ (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) (defn create-module [name] + "(-> Text (Lux (,)))" (fn [state] (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) (defn enter-module [name] + "(-> Text (Lux (,)))" (fn [state] (return* (->> state (&/update$ &/$MODULES #(&/|put name +init+ %)) (&/set$ &/$ENVS (&/|list (&/env name)))) nil))) + +(defn tags-by-module [module] + "(-> Text (Lux (List (, Text (, Int (List Text))))))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (return* state (&/get$ $tags =module)) + (fail* (str "[Lux Error] Unknown module: " module))) + )) + +(defn declare-tags [module tag-names] + "(-> Text (List Text) (Lux (,)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$MODULES + (fn [=modules] + (&/|update module + #(&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags) table))) + (&/get$ $tags %) + (&/enumerate tag-names)) + %) + =modules)) + state) + nil)) + (fail* (str "[Lux Error] Unknown module: " module))))) + +(defn tag-index [module tag-name] + "(-> Text Text (Lux Int))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 0)) + (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Lux Error] Unknown module: " module))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index f690ef65f..73b2bb684 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -13,47 +13,53 @@ ;; [Tags] (defmacro deftags [prefix & names] - `(do ~@(for [name names] - `(def ~(symbol (str "$" name)) ~(str prefix name))))) + `(do ~@(for [[name idx] (map vector names (range (count names)))] + `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(def $Nil "lux;Nil") -(def $Cons "lux;Cons") +(deftags "" + "Nil" + "Cons") ;; Maybe -(def $None "lux;None") -(def $Some "lux;Some") +(deftags "" + "None" + "Some") ;; Meta -(def $Meta "lux;Meta") +(deftags "" + "Meta") ;; Either -(def $Left "lux;Left") -(def $Right "lux;Right") +(deftags "" + "Left" + "Right") ;; AST -(def $BoolS "lux;BoolS") -(def $IntS "lux;IntS") -(def $RealS "lux;RealS") -(def $CharS "lux;CharS") -(def $TextS "lux;TextS") -(def $SymbolS "lux;SymbolS") -(def $TagS "lux;TagS") -(def $FormS "lux;FormS") -(def $TupleS "lux;TupleS") -(def $RecordS "lux;RecordS") +(deftags "" + "BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "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") +(deftags "" + "DataT" + "TupleT" + "VariantT" + "RecordT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT") ;; [Fields] ;; Binding @@ -100,7 +106,7 @@ (defn T [& elems] (to-array elems)) -(defn V [tag value] +(defn V [^Long tag value] (to-array [tag value])) (defn R [& kvs] @@ -726,6 +732,7 @@ output))))) (defn show-ast [ast] + ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast ($Meta _ ($BoolS ?value)) (pr-str ?value) @@ -762,6 +769,10 @@ ($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))) )) (defn ident->text [ident] @@ -814,6 +825,7 @@ false)) (defn ^:private enumerate* [idx xs] + "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) (V $Cons (T (T idx x) @@ -824,6 +836,7 @@ )) (defn enumerate [xs] + "(All [a] (-> (List a) (List (, Int a))))" (enumerate* 0 xs)) (def modules @@ -836,3 +849,28 @@ (if test body (return nil))) + +(defn |at [idx xs] + "(All [a] (-> Int (List a) (Maybe a)))" + ;; (prn '|at idx (aget idx 0)) + (|case xs + ($Cons x xs*) + (cond (< idx 0) + (V $None nil) + + (= idx 0) + (V $Some x) + + :else ;; > 1 + (|at (dec idx) xs*)) + + ($Nil) + (V $None nil) + )) + +(defn normalize [ident] + "(-> Ident (Lux Ident))" + (|case ident + ["" name] (|do [module get-module-name] + (return (T module name))) + _ (return ident))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 490491bd0..7622e3002 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -61,13 +61,13 @@ (&a/$record ?elems) (&&lux/compile-record compile-expression ?type ?elems) - (&/$Local ?idx) + (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) (&a/$captured ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - (&/$Global ?owner-class ?name) + (&a/$var (&/$Global ?owner-class ?name)) (&&lux/compile-global compile-expression ?type ?owner-class ?name) (&a/$apply ?fn ?args) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 87327311c..9baefa21c 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -37,11 +37,13 @@ (do-template [<name> <class> <sig> <caster>] (defn <name> [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW <class>) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (<caster> value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]] + :let [_ (try (doto *writer* + (.visitTypeInsn Opcodes/NEW <class>) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (<caster> value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>)) + (catch Exception e + (assert false (prn-str '<name> (alength value) (aget value 0) (aget value 1)))))]] (return nil))) compile-int "java/lang/Long" "(J)V" long @@ -99,6 +101,7 @@ (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitLdcInsn ?tag) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)))] @@ -148,6 +151,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -174,6 +178,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/type.clj b/src/lux/type.clj index 0a80d4fbc..553318daf 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -23,39 +23,73 @@ (def Unit (&/V &/$TupleT (&/|list))) (def $Void (&/V &/$VariantT (&/|list))) +(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) +(defn ^:private Bound$ [name] + (&/V &/$BoundT name)) +(defn ^:private Lambda$ [in out] + (&/V &/$LambdaT (&/T in out))) +(defn ^:private App$ [fun arg] + (&/V &/$AppT (&/T fun arg))) +(defn ^:private Tuple$ [members] + (&/V &/$TupleT members)) +(defn ^:private Variant$ [members] + (&/V &/$VariantT members)) +(defn ^:private Record$ [members] + (&/V &/$RecordT members)) + (def IO - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" - (&/V &/$LambdaT (&/T Unit (&/V &/$BoundT "a")))))) + (&/V &/$AllT (&/T empty-env "IO" "a" + (Lambda$ Unit (Bound$ "a"))))) (def List - (&/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"))))))))))) + (&/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")))) + ))))) (def Maybe - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" - (&/V &/$VariantT (&/|list (&/T &/$None Unit) - (&/T &/$Some (&/V &/$BoundT "a"))))))) + (&/V &/$AllT (&/T empty-env "lux;Maybe" "a" + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (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)))) + (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 + )))) + $Void))) (defn fAll [name arg body] (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) @@ -63,130 +97,187 @@ (def Bindings (fAll "lux;Bindings" "k" (fAll "" "v" - (&/V &/$RecordT (&/|list (&/T "lux;counter" Int) - (&/T "lux;mappings" (&/V &/$AppT (&/T List - (&/V &/$TupleT (&/|list (&/V &/$BoundT "k") - (&/V &/$BoundT "v"))))))))))) + (Record$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v"))))))))) (def Env - (let [bindings (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings (&/V &/$BoundT "k"))) - (&/V &/$BoundT "v")))] + (let [bindings (App$ (App$ Bindings (Bound$ "k")) + (Bound$ "v"))] (fAll "lux;Env" "k" (fAll "" "v" - (&/V &/$RecordT - (&/|list (&/T "lux;name" Text) - (&/T "lux;inner-closures" Int) - (&/T "lux;locals" bindings) - (&/T "lux;closure" bindings) - )))))) + (Record$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + )))))) (def Cursor - (&/V &/$TupleT (&/|list Text Int Int))) + (Tuple$ (&/|list Text Int Int))) (def Meta (fAll &/$Meta "m" (fAll "" "v" - (&/V &/$VariantT (&/|list (&/T &/$Meta (&/V &/$TupleT (&/|list (&/V &/$BoundT "m") - (&/V &/$BoundT "v"))))))))) + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v")))))))) -(def Ident (&/V &/$TupleT (&/|list Text Text))) +(def Ident (Tuple$ (&/|list Text Text))) (def 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*))] + (let [AST* (App$ (Bound$ "w") + (App$ (Bound$ "lux;AST'") + (Bound$ "w"))) + AST*List (App$ List AST*)] (fAll "lux;AST'" "w" - (&/V &/$VariantT (&/|list (&/T &/$BoolS Bool) - (&/T &/$IntS Int) - (&/T &/$RealS Real) - (&/T &/$CharS Char) - (&/T &/$TextS Text) - (&/T &/$SymbolS Ident) - (&/T &/$TagS Ident) - (&/T &/$FormS AST*List) - (&/T &/$TupleS AST*List) - (&/T &/$RecordS (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list AST* AST*)))))) - )))) + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + )))) (def AST - (let [w (&/V &/$AppT (&/T Meta Cursor))] - (&/V &/$AppT (&/T w (&/V &/$AppT (&/T AST* w)))))) + (let [w (App$ Meta Cursor)] + (App$ w (App$ AST* w)))) -(def ^:private ASTList (&/V &/$AppT (&/T List AST))) +(def ^:private ASTList (App$ List AST)) (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V &/$VariantT (&/|list (&/T &/$Left (&/V &/$BoundT "l")) - (&/T &/$Right (&/V &/$BoundT "r"))))))) + (Variant$ (&/|list (&/T &/$Left (Bound$ "l")) + (&/T &/$Right (Bound$ "r"))))))) (def StateE (fAll "lux;StateE" "s" (fAll "" "a" - (&/V &/$LambdaT (&/T (&/V &/$BoundT "s") - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Either Text)) - (&/V &/$TupleT (&/|list (&/V &/$BoundT "s") - (&/V &/$BoundT "a")))))))))) + (Lambda$ (Bound$ "s") + (App$ (App$ Either Text) + (Tuple$ (&/|list (Bound$ "s") + (Bound$ "a")))))))) (def Reader - (&/V &/$AppT (&/T List - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Meta Cursor)) - Text))))) + (App$ List + (App$ (App$ Meta Cursor) + Text))) (def HostState - (&/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"))))) + (Record$ + (&/|list + ;; "lux;writer" + (&/V &/$DataT "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (&/V &/$DataT "java.lang.ClassLoader") + ;; "lux;classes" + (&/V &/$DataT "clojure.lang.Atom")))) (def DefData* (fAll "lux;DefData'" "" - (&/V &/$VariantT (&/|list (&/T "lux;TypeD" Type) - (&/T "lux;ValueD" (&/V &/$TupleT (&/|list Type Unit))) - (&/T "lux;MacroD" (&/V &/$BoundT "")) - (&/T "lux;AliasD" Ident))))) + (Variant$ (&/|list + ;; "lux;TypeD" + Type + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + )))) (def LuxVar - (&/V &/$VariantT (&/|list (&/T "lux;Local" Int) - (&/T "lux;Global" Ident)))) + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident))) (def $Module (fAll "lux;$Module" "Compiler" - (&/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 &/$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 &/$AppT (&/T List Text))))))) + (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)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (List Ident))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List + Ident)))))) + )))) (def $Compiler - (&/V &/$AppT (&/T (fAll "lux;Compiler" "" - (&/V &/$RecordT - (&/|list (&/T "lux;source" Reader) - (&/T "lux;modules" (&/V &/$AppT (&/T List (&/V &/$TupleT - (&/|list Text - (&/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) - (&/T "lux;expected" Type) - (&/T "lux;cursor" Cursor) - ))) - $Void))) + (App$ (fAll "lux;Compiler" "" + (Record$ + (&/|list + ;; "lux;source" + Reader + ;; "lux;modules" + (App$ List (Tuple$ + (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;host" + HostState + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;expected" + Type + ;; "lux;cursor" + Cursor + ))) + $Void)) (def Macro - (&/V &/$LambdaT (&/T ASTList - (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE $Compiler)) - ASTList))))) + (Lambda$ ASTList + (App$ (App$ StateE $Compiler) + ASTList))) (defn bound? [id] (fn [state] @@ -297,30 +388,24 @@ (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (&/V &/$LambdaT (&/T =arg =return)))) + (return (Lambda$ =arg =return))) (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (&/V &/$AppT (&/T =lambda =param)))) + (return (App$ =lambda =param))) (&/$TupleT ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (&/V &/$TupleT =members))) + (return (Tuple$ =members))) (&/$VariantT ?members) - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V &/$VariantT =members))) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Variant$ =members))) (&/$RecordT ?members) - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V &/$RecordT =members))) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Record$ =members))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -380,23 +465,14 @@ (if (&/|empty? cases) "(|)" (str "(| " (->> cases - (&/|map (fn [kv] - (|case kv - [k (&/$TupleT (&/$Nil))] - (str "#" k) - - [k v] - (str "(#" k " " (show-type v) ")")))) + (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) (&/$RecordT fields) (str "(& " (->> fields - (&/|map (fn [kv] - (|case kv - [k v] - (str "#" k " " (show-type v))))) + (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") @@ -429,7 +505,9 @@ [args body*]))] (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) - )) + + _ + (assert false (prn-str 'show-type (aget type 0))))) (defn type= [x y] (or (clojure.lang.Util/identical x y) @@ -438,24 +516,17 @@ (.equals ^Object xname yname) [(&/$TupleT xelems) (&/$TupleT yelems)] - (&/fold2 (fn [old x y] - (and old (type= x y))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) [(&/$VariantT xcases) (&/$VariantT ycases)] - (&/fold2 (fn [old xcase ycase] - (|let [[xname xtype] xcase - [yname ytype] ycase] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xcases ycases) [(&/$RecordT xslots) (&/$RecordT yslots)] - (&/fold2 (fn [old xslot yslot] - (|let [[xname xtype] xslot - [yname ytype] yslot] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xslots yslots) @@ -522,23 +593,17 @@ (defn beta-reduce [env type] (|case type - (&/$VariantT ?cases) - (&/V &/$VariantT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?cases)) + (&/$VariantT ?members) + (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$RecordT ?fields) - (&/V &/$RecordT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?fields)) + (&/$RecordT ?members) + (Record$ (&/|map (partial beta-reduce env) ?members)) (&/$TupleT ?members) - (&/V &/$TupleT (&/|map (partial beta-reduce env) ?members)) + (Tuple$ (&/|map (partial beta-reduce env) ?members)) (&/$AppT ?type-fn ?type-arg) - (&/V &/$AppT (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) + (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env @@ -549,7 +614,7 @@ type) (&/$LambdaT ?input ?output) - (&/V &/$LambdaT (&/T (beta-reduce env ?input) (beta-reduce env ?output))) + (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output)) (&/$BoundT ?name) (if-let [bound (&/|get ?name env)] @@ -660,13 +725,13 @@ (|case ((|do [F1 (deref ?eid)] (fn [state] (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) state)] (&/$Right state* output) (return* state* output) (&/$Left _) - ((check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual) + ((check* class-loader fixpoints (App$ F1 A1) actual) state)))) state) (&/$Right state* output) @@ -674,7 +739,7 @@ (&/$Left _) (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) @@ -691,7 +756,7 @@ [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual)) + (check* class-loader fixpoints (App$ F1 A1) actual)) state) (&/$Right state* output) (return* state* output) @@ -713,7 +778,7 @@ [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) @@ -795,25 +860,17 @@ (return (&/T fixpoints* nil))) [(&/$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] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) fixpoints e!cases a!cases)] (return (&/T fixpoints* nil))) [(&/$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] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) fixpoints e!slots a!slots)] (return (&/T fixpoints* nil))) |