aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux117
-rw-r--r--source/lux/data/char.lux3
-rw-r--r--source/lux/data/io.lux3
-rw-r--r--source/lux/data/number.lux8
-rw-r--r--source/lux/host/java.lux84
-rw-r--r--source/lux/meta/lux.lux7
-rw-r--r--source/lux/meta/syntax.lux2
-rw-r--r--source/program.lux2
-rw-r--r--src/lux/analyser/case.clj120
-rw-r--r--src/lux/analyser/lux.clj18
-rw-r--r--src/lux/compiler/base.clj1
-rw-r--r--src/lux/compiler/cache.clj2
-rw-r--r--src/lux/compiler/host.clj2
-rw-r--r--src/lux/compiler/lambda.clj2
-rw-r--r--src/lux/compiler/lux.clj113
-rw-r--r--src/lux/compiler/type.clj97
-rw-r--r--src/lux/type.clj20
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 "")) ")"))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 09:22:37 +0000