aboutsummaryrefslogtreecommitdiff
path: root/source
diff options
context:
space:
mode:
authorEduardo Julian2015-07-26 20:57:21 -0400
committerEduardo Julian2015-07-26 20:57:21 -0400
commit9b7cfd6f5bcc93e2f2f0c3129b7ec6d62c69bb37 (patch)
tree186f2fb0f81589df819c87d37ba4a6f0961ebdc4 /source
parent4cd9b0c9242f1105e50ad9b42b7f6f5d074f14b4 (diff)
- Fixed a pattern-matching error where generalizations of types (universal-quantification / AllT) was not being taken into account properly when destructuring.
- Fixed a compiler error wherein the types of definitions didn't generate (correctly) the structures necessary for storage inside the class _meta(data) field. - Improved both the "open" and "import" macros with extra features.
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
8 files changed, 133 insertions, 93 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