diff options
| -rw-r--r-- | source/lux.lux | 117 | ||||
| -rw-r--r-- | source/lux/data/char.lux | 3 | ||||
| -rw-r--r-- | source/lux/data/io.lux | 3 | ||||
| -rw-r--r-- | source/lux/data/number.lux | 8 | ||||
| -rw-r--r-- | source/lux/host/java.lux | 84 | ||||
| -rw-r--r-- | source/lux/meta/lux.lux | 7 | ||||
| -rw-r--r-- | source/lux/meta/syntax.lux | 2 | ||||
| -rw-r--r-- | source/program.lux | 2 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 120 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 18 | ||||
| -rw-r--r-- | src/lux/compiler/base.clj | 1 | ||||
| -rw-r--r-- | src/lux/compiler/cache.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 113 | ||||
| -rw-r--r-- | src/lux/compiler/type.clj | 97 | ||||
| -rw-r--r-- | src/lux/type.clj | 20 |
17 files changed, 367 insertions, 234 deletions
diff --git a/source/lux.lux b/source/lux.lux index 50f8f1af2..8f7e4fa04 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1069,7 +1069,7 @@ _ #Nil)) -(def'' #export (text:= x y) +(def'' (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y])) @@ -1196,7 +1196,7 @@ (-> Bool Bool) (if x false true)) -(def'' #export (text:++ x y) +(def'' (text:++ x y) (-> Text Text Text) (_jvm_invokevirtual java.lang.String concat [java.lang.String] x [y])) @@ -1883,8 +1883,11 @@ (#Exclude (List Text)) #Nothing)) +(deftype Openings + (, Text (List Ident))) + (deftype Import - (, Text (Maybe Text) Referrals)) + (, Text (Maybe Text) Referrals (Maybe Openings))) (def (extract-defs defs) (-> (List Syntax) (Lux (List Text))) @@ -1932,6 +1935,26 @@ _ (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) +(def (extract-symbol syntax) + (-> Syntax (Lux Ident)) + (case syntax + (#Meta [_ (#SymbolS ident)]) + (return ident) + + _ + (fail "Not a symbol."))) + +(def (parse-openings tokens) + (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (do Lux/Monad + [structs' (map% Lux/Monad extract-symbol structs)] + (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + + _ + (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) + (def (decorate-imports super-name tokens) (-> Text (List Syntax) (Lux (List Syntax))) (map% Lux/Monad @@ -1951,33 +1974,31 @@ (def (parse-imports imports) (-> (List Syntax) (Lux (List Import))) (do Lux/Monad - [referrals' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) - (lambda [token] - (case token - (#Meta [_ (#SymbolS ["" m-name])]) - (;return (list [m-name #None #All])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) - (do Lux/Monad - [alias+extra' (parse-alias extra) - #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) - alias+extra')] - referral+extra'' (parse-referrals extra') - #let [[referral extra''] (: (, Referrals (List Syntax)) - referral+extra'')] - extra''' (decorate-imports m-name extra'') - sub-imports (parse-imports extra''')] - (;return (case referral - #Nothing (case alias - #None sub-imports - (#Some _) (list& [m-name alias referral] sub-imports)) - _ (list& [m-name alias referral] sub-imports)))) - - _ - (fail "Wrong syntax for import")))) - imports)] - (;return (list:join referrals')))) + [imports' (map% Lux/Monad + (: (-> Syntax (Lux (List Import))) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" m-name])]) + (;return (list [m-name #None #All #None])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (do Lux/Monad + [alias+extra (parse-alias extra) + #let [[alias extra] alias+extra] + referral+extra (parse-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-openings extra) + #let [[openings extra] openings+extra] + extra (decorate-imports m-name extra) + sub-imports (parse-imports extra)] + (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) + [#Nothing #None #None] sub-imports + _ (list& [m-name alias referral openings] sub-imports)))) + + _ + (fail "Wrong syntax for import")))) + imports)] + (;return (list:join imports')))) (def (module-exists? module state) (-> Text (Lux Bool)) @@ -2131,16 +2152,16 @@ (: (-> Import (Lux Import)) (lambda [import] (case import - [m-name m-alias m-referrals] + [m-name m-alias m-referrals m-openings] (do Lux/Monad [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals])))))) + (;return (: Import [m-name m-alias m-referrals m-openings])))))) imports) unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) (lambda [import] (case import - [m-name _ _] + [m-name _ _ _] (do Lux/Monad [? (module-exists? m-name)] (;return (if ? @@ -2155,7 +2176,7 @@ (: (-> Import (Lux (List Syntax))) (lambda [import] (case import - [m-name m-alias m-referrals] + [m-name m-alias m-referrals m-openings] (do Lux/Monad [defs (case m-referrals #All @@ -2172,7 +2193,18 @@ (;return (filter (. not (is-member? -defs)) *defs))) #Nothing - (;return (list)))] + (;return (list))) + #let [openings (: (List Syntax) + (case m-openings + #None + (list) + + (#Some [prefix structs]) + (map (: (-> Ident Syntax) + (lambda [struct] + (let [[_ name] struct] + (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) + structs)))]] (;return ($ list:++ (list (` (_lux_import (~ (text$ m-name))))) (case m-alias @@ -2181,7 +2213,8 @@ (map (: (-> Text Syntax) (lambda [def] (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs))))))) + defs) + openings)))))) imports)] (;return (list:join output'))) @@ -2583,16 +2616,22 @@ (defmacro #export (open tokens) (case tokens - (\ (list (#Meta [_ (#SymbolS struct-name)]))) + (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens')) (do Lux/Monad - [struct-type (find-var-type struct-name)] + [#let [prefix (case tokens' + (\ (list (#Meta [_ (#TextS prefix)]))) + prefix + + _ + "")] + struct-type (find-var-type struct-name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) (return (map (: (-> (, Text Type) Syntax) (lambda [slot] (let [[sname stype] slot [module name] (split-slot sname)] - (` (_lux_def (~ (symbol$ ["" name])) + (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) slots)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 42e57509e..5dac9a3c7 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -8,7 +8,8 @@ (;import lux (.. (eq #as E) - (show #as S))) + (show #as S) + (text #as T #open ("text:" Text/Monoid)))) ## [Structures] (defstruct #export Char/Eq (E;Eq Char) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index c08023df5..17e8d727a 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -10,7 +10,8 @@ (lux/meta macro) (lux/control (functor #as F) (monad #as M)) - lux/data/list) + (.. list + (text #as T #open ("text:" Text/Monoid)))) ## Types (deftype #export (IO a) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux index 8da674d88..b222de15c 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number.lux @@ -8,10 +8,10 @@ (;import lux (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) + (.. (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) ## Signatures (defsig #export (Number n) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux index 12525d3f2..9bd0c838c 100644 --- a/source/lux/host/java.lux +++ b/source/lux/host/java.lux @@ -10,14 +10,12 @@ (lux (control (monoid #as m) (functor #as F) (monad #as M #refer (#only do))) - (data list + (data (list #as l #refer #all #open ("" List/Functor)) (text #as text)) (meta lux macro syntax))) -## (open List/Functor) - ## [Utils/Parsers] (def finally^ (Parser Syntax) @@ -110,29 +108,29 @@ (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) (emit (list (` (_jvm_try (~ body) - (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches)) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally)))))))))))) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (do Lux/Monad [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name))]] - (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - members))] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] (~@ members')))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] @@ -142,35 +140,35 @@ [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name)) - fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - fields)) - methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs)))] - (~ (text$ output)) - [(~@ (:: List/Functor (F;map text$ modifiers)))] - (~ body)))))) - methods))]] + fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))))) + fields) + methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ (map text$ interfaces))] [(~@ fields')] [(~@ methods')])))))) (defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ (map text$ arg-classes))] [(~@ args)]))))) (defsyntax #export (instance? [class local-symbol^] obj) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index a28d6e5d4..99ca200cf 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -14,7 +14,8 @@ (lux/data list maybe (show #as S) - (number #as N))) + (number #as N) + (text #as T #open ("text:" Text/Monoid Text/Eq)))) ## [Types] ## (deftype (Lux a) @@ -209,10 +210,10 @@ (lambda [b] (let [[label _] b] label)))) (:: List/Functor) (interpose " ") - (foldL text:++ "")))))) + (foldL text:++ text:unit)))))) (:: List/Functor) (interpose "\n") - (foldL text:++ ""))) + (foldL text:++ text:unit))) (def (try-both f x1 x2) (All [a b] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 1fe85c32f..83702f75d 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -14,7 +14,7 @@ (data (eq #as E) (bool #as b) (char #as c) - (text #as t) + (text #as t #open ("text:" Text/Monoid Text/Eq)) list))) ## [Utils] diff --git a/source/program.lux b/source/program.lux index 052c0bf41..18a2a76ab 100644 --- a/source/program.lux +++ b/source/program.lux @@ -30,7 +30,7 @@ (reader #as r) show state - (text #as t) + (text #as t #open ("text:" Text/Monoid)) writer) (host java) (meta lux diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 659b2b0f6..cb76d8d54 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -23,7 +23,8 @@ (fail "##9##")))] (resolve-type type*)) - [["lux;AllT" ?id]] + [["lux;AllT" [_aenv _aname _aarg _abody]]] + ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] (&type/actual-type =type)) @@ -35,6 +36,79 @@ [_] (&type/actual-type type))) +(defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + (matchv ::M/objects [type] + [["lux;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]]] + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + [["lux;VarT" ?id]] + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + [_] + (assert false (aget type 0)) + )) + +(defn adjust-type [type] + "(-> Type (Lux Type))" + (adjust-type* (&/|list) type)) + (defn ^:private analyse-pattern [value-type pattern kont] (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] @@ -71,27 +145,31 @@ (return (&/T (&/V "TextTestAC" ?value) =kont))) [["lux;TupleS" ?members]] - (|do [value-type* (resolve-type value-type)] + (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (matchv ::M/objects [value-type*] - [["lux;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) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont))))) - - [_] - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + (matchv ::M/objects [value-type*] + [["lux;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) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V "TupleTestAC" =tests) =kont))))) + + [_] + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) [["lux;RecordS" ?slots]] - (|do [value-type* (resolve-type value-type)] + (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] + value-type* (adjust-type value-type) + ;; :let [_ (prn 'POST (&type/show-type value-type*))] + ;; value-type* (resolve-type value-type) + ] (matchv ::M/objects [value-type*] [["lux;RecordT" ?slot-types]] (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) @@ -118,7 +196,7 @@ [["lux;TagS" ?ident]] (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) + value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list)))) @@ -129,7 +207,7 @@ ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) + value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type ?value kont)] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index b25dff9eb..4a912f1c1 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -219,7 +219,7 @@ [["lux;Cons" [?arg ?args*]]] (|do [?fun-type* (&type/actual-type fun-type)] (matchv ::M/objects [?fun-type*] - [["lux;AllT" _]] + [["lux;AllT" [_aenv _aname _aarg _abody]]] ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -230,11 +230,10 @@ (matchv ::M/objects [$var] [["lux;VarT" ?id]] (|do [? (&type/bound? ?id) - _ (if ? - (return nil) - (|do [ex &type/existential] - (&type/set-var ?id ex))) - type** (&type/clean $var =output-t)] + type** (if ? + (&type/clean $var =output-t) + (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))] + (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) @@ -262,11 +261,11 @@ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) - ;; (= "case" ?name)) + ;; (= "open" ?name)) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn ?module "case")))] + ;; (prn ?module "open")))] ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) @@ -328,6 +327,9 @@ ;; dtype* (&type/actual-type dtype) ] (matchv ::M/objects [dtype] + [["lux;BoundT" ?vname]] + (return (&/T _expr exo-type)) + [["lux;ExT" _]] (return (&/T _expr exo-type)) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index e7b338b16..0631f51e8 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -29,6 +29,7 @@ (def ^String version "0.2") (def ^String input-dir "source") (def ^String output-dir "target/jvm") +(def ^String function-class "lux/Function") (def ^String local-prefix "l") (def ^String partial-prefix "p") diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index d6f0b1db7..57e81a2b0 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -55,7 +55,7 @@ (defn clean [state] "(-> Compiler (,))" (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) - outdated? #(-> % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) + outdated? #(-> ^File % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))] (doseq [f outdate-files] (clean-file f)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index fd34a45a7..3df09b29e 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -593,7 +593,7 @@ _ (compile ?body) :let [_ (doto main-writer (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature))] + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))] :let [_ (doto main-writer (.visitInsn Opcodes/POP) (.visitInsn Opcodes/RETURN) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index d97cc1f26..ccd12e68a 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -97,7 +97,7 @@ class-name (str (&host/->module-class (&/|head ?scope)) "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" (into-array ["lux/Function"])) + class-name nil "java/lang/Object" (into-array [&&/function-class])) (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 32a7af751..f1c261d6b 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -21,7 +21,8 @@ (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler [base :as &&] - [lambda :as &&lambda])) + [lambda :as &&lambda] + [type :as &&type])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -63,7 +64,10 @@ (|do [:let [_ (doto *writer* (.visitInsn Opcodes/DUP) (.visitLdcInsn (int idx)))] - ret (compile elem) + ret (try (compile elem) + (catch Exception e + (prn 'compile-tuple (aget elem 0) (->> ?elems (&/|map #(aget % 0)) &/->seq)) + (throw e))) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return ret))) (&/|range num-elems) ?elems)] @@ -130,110 +134,11 @@ _ (compile ?fn) _ (&/map% (fn [?arg] (|do [=arg (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)]] (return =arg))) ?args)] (return nil))) -(defn ^:private type->analysis [type] - (matchv ::M/objects [type] - [["lux;DataT" ?class]] - (&/T (&/V "variant" (&/T "lux;DataT" - (&/T (&/V "text" ?class) &type/$Void))) - &type/$Void) - - [["lux;TupleT" ?members]] - (&/T (&/V "variant" (&/T "lux;TupleT" - (&/fold (fn [tail head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (type->analysis head) - tail)) - &type/$Void)))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ?members)))) - &type/$Void) - - [["lux;VariantT" ?cases]] - (&/T (&/V "variant" (&/T "lux;VariantT" - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) - (type->analysis htype))) - &type/$Void) - tail)) - &type/$Void))))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ?cases)))) - &type/$Void) - - [["lux;RecordT" ?slots]] - (&/T (&/V "variant" (&/T "lux;RecordT" - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) - (type->analysis htype))) - &type/$Void) - tail)) - &type/$Void))))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ?slots)))) - &type/$Void) - - [["lux;LambdaT" [?input ?output]]] - (&/T (&/V "variant" (&/T "lux;LambdaT" - (&/T (&/V "tuple" (&/|map type->analysis (&/|list ?input ?output))) - &type/$Void))) - &type/$Void) - - [["lux;AllT" [?env ?name ?arg ?body]]] - (&/T (&/V "variant" (&/T "lux;AllT" - (&/T (&/V "tuple" (&/|list (matchv ::M/objects [?env] - [["lux;None" _]] - (&/V "variant" (&/T "lux;Some" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - - [["lux;Some" ??env]] - (&/V "variant" (&/T "lux;Some" - (&/T (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) - (type->analysis htype))) - &type/$Void) - tail)) - &type/$Void))))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ??env)) - &type/$Void)))) - (&/T (&/V "text" ?name) &type/$Void) - (&/T (&/V "text" ?arg) &type/$Void) - (type->analysis ?body))) - &type/$Void))) - &type/$Void) - - [["lux;BoundT" ?name]] - (&/T (&/V "variant" (&/T "lux;BoundT" - (&/T (&/V "text" ?name) &type/$Void))) - &type/$Void) - - [["lux;AppT" [?fun ?arg]]] - (&/T (&/V "variant" (&/T "lux;AppT" - (&/T (&/V "tuple" (&/|map type->analysis (&/|list ?fun ?arg))) - &type/$Void))) - &type/$Void) - )) - (defn ^:private compile-def-type [compile ?body ?def-data] (|do [^MethodVisitor **writer** &/get-writer] (matchv ::M/objects [?def-data] @@ -260,7 +165,7 @@ (&/T ?def-value ?type-expr) [[?def-value ?def-type]] - (&/T ?body (type->analysis ?def-type)))] + (&/T ?body (&&type/->analysis ?def-type)))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V @@ -284,7 +189,7 @@ current-class (str (&host/->module-class module-name) "/" def-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array ["lux/Function"])) + current-class nil "java/lang/Object" (into-array [&&/function-class])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name) (doto (.visitEnd))) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj new file mode 100644 index 000000000..a92911444 --- /dev/null +++ b/src/lux/compiler/type.clj @@ -0,0 +1,97 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.type + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let]] + [type :as &type]))) + +;; [Utils] +(defn ^:private variant$ [tag body] + "(-> Text Analysis Analysis)" + (&/T (&/V "variant" (&/T tag body)) + &type/$Void)) + +(defn ^:private tuple$ [members] + "(-> (List Analysis) Analysis)" + (&/T (&/V "tuple" members) + &type/$Void)) + +(defn ^:private text$ [text] + "(-> Text Analysis)" + (&/T (&/V "text" text) + &type/$Void)) + +(def ^:private $Nil + "Analysis" + (variant$ "lux;Nil" (tuple$ (&/|list)))) + +(defn ^:private Cons$ [head tail] + "(-> Analysis Analysis Analysis)" + (variant$ "lux;Cons" (tuple$ (&/|list head tail)))) + +;; [Exports] +(defn ->analysis [type] + "(-> Type Analysis)" + (matchv ::M/objects [type] + [["lux;DataT" ?class]] + (variant$ "lux;DataT" (text$ ?class)) + + [["lux;TupleT" ?members]] + (variant$ "lux;TupleT" + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) + + [["lux;VariantT" ?cases]] + (variant$ "lux;VariantT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?cases))) + + [["lux;RecordT" ?slots]] + (variant$ "lux;RecordT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?slots))) + + [["lux;LambdaT" [?input ?output]]] + (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + + [["lux;AllT" [?env ?name ?arg ?body]]] + (variant$ "lux;AllT" + (tuple$ (&/|list (matchv ::M/objects [?env] + [["lux;None" _]] + (variant$ "lux;Some" (tuple$ (&/|list))) + + [["lux;Some" ??env]] + (variant$ "lux;Some" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body)))) + + [["lux;BoundT" ?name]] + (variant$ "lux;BoundT" (text$ ?name)) + + [["lux;AppT" [?fun ?arg]]] + (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + )) diff --git a/src/lux/type.clj b/src/lux/type.clj index f1a5b7623..af2bbf30f 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -284,7 +284,7 @@ _ (&/map% delete-var (&/|reverse =vars))] (return output))) -(defn ^:private clean* [?tid type] +(defn clean* [?tid type] (matchv ::M/objects [type] [["lux;VarT" ?id]] (if (.equals ^Object ?tid ?id) @@ -345,6 +345,15 @@ [_] (fail (str "[Type Error] Not type-var: " (show-type tvar))))) +(defn ^:private unravel-fun [type] + (matchv ::M/objects [type] + [["lux;LambdaT" [?in ?out]]] + (|let [[??out ?args] (unravel-fun ?out)] + (&/T ??out (&/|cons ?in ?args))) + + [_] + (&/T type (&/|list)))) + (defn ^:private unravel-app [fun-type] (matchv ::M/objects [fun-type] [["lux;AppT" [?left ?right]]] @@ -389,17 +398,18 @@ (&/fold str "")) ")") [["lux;LambdaT" [input output]]] - (str "(-> " (show-type input) " " (show-type output) ")") + (|let [[?out ?ins] (unravel-fun type)] + (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) [["lux;VarT" id]] (str "⌈" id "⌋") - [["lux;BoundT" name]] - name - [["lux;ExT" ?id]] (str "⟨" ?id "⟩") + [["lux;BoundT" name]] + name + [["lux;AppT" [_ _]]] (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) |