aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--input/lux.lux1400
-rw-r--r--input/lux/codata/stream.lux63
-rw-r--r--input/lux/control/comonad.lux54
-rw-r--r--input/lux/control/functor.lux35
-rw-r--r--input/lux/control/lazy.lux47
-rw-r--r--input/lux/control/monad.lux107
-rw-r--r--input/lux/control/monoid.lux57
-rw-r--r--input/lux/data/bounded.lux26
-rw-r--r--input/lux/data/dict.lux83
-rw-r--r--input/lux/data/eq.lux35
-rw-r--r--input/lux/data/io.lux51
-rw-r--r--input/lux/data/list.lux218
-rw-r--r--input/lux/data/number.lux64
-rw-r--r--input/lux/data/ord.lux56
-rw-r--r--input/lux/data/show.lux27
-rw-r--r--input/lux/data/state.lux13
-rw-r--r--input/lux/data/text.lux139
-rw-r--r--input/lux/meta/lux.lux185
-rw-r--r--input/lux/meta/macro.lux54
-rw-r--r--input/lux/meta/syntax.lux237
-rw-r--r--input/program.lux39
-rw-r--r--src/lux/analyser.clj32
-rw-r--r--src/lux/analyser/case.clj11
-rw-r--r--src/lux/analyser/env.clj16
-rw-r--r--src/lux/analyser/host.clj9
-rw-r--r--src/lux/analyser/lux.clj109
-rw-r--r--src/lux/analyser/module.clj79
-rw-r--r--src/lux/base.clj14
-rw-r--r--src/lux/compiler.clj2
-rw-r--r--src/lux/compiler/host.clj27
-rw-r--r--src/lux/compiler/lux.clj13
-rw-r--r--src/lux/lexer.clj20
-rw-r--r--src/lux/type.clj37
33 files changed, 2825 insertions, 534 deletions
diff --git a/input/lux.lux b/input/lux.lux
index 282ca97b1..de407bafe 100644
--- a/input/lux.lux
+++ b/input/lux.lux
@@ -126,6 +126,7 @@
## (, Text Int Int))
(_lux_def Cursor
(#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
+(_lux_export Cursor)
## (deftype (Meta m v)
## (| (#Meta (, m v))))
@@ -234,6 +235,7 @@
(#Cons [["lux;MacroD" (#BoundT "")]
(#Cons [["lux;AliasD" Ident]
#Nil])])])]))]))
+(_lux_export DefData')
## (deftype LuxVar
## (| (#Local Int)
@@ -341,32 +343,32 @@
(_lux_lambda _ state
(#Left msg)))))
-(_lux_def $text
+(_lux_def text$
(_lux_: (#LambdaT [Text Syntax])
(_lux_lambda _ text
(_meta (#TextS text)))))
-(_lux_def $symbol
+(_lux_def symbol$
(_lux_: (#LambdaT [Ident Syntax])
(_lux_lambda _ ident
(_meta (#SymbolS ident)))))
-(_lux_def $tag
+(_lux_def tag$
(_lux_: (#LambdaT [Ident Syntax])
(_lux_lambda _ ident
(_meta (#TagS ident)))))
-(_lux_def $form
+(_lux_def form$
(_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
(_lux_lambda _ tokens
(_meta (#FormS tokens)))))
-(_lux_def $tuple
+(_lux_def tuple$
(_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax])
(_lux_lambda _ tokens
(_meta (#TupleS tokens)))))
-(_lux_def $record
+(_lux_def record$
(_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax])
(_lux_lambda _ tokens
(_meta (#RecordS tokens)))))
@@ -376,7 +378,7 @@
(_lux_lambda _ tokens
(_lux_case tokens
(#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
- (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"])
(#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))
#Nil]))
@@ -439,7 +441,7 @@
(#Cons [body #Nil])])])])))
#Nil])])])))
#Nil])])])))
- (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])])))
+ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
#Nil])]))
(#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
@@ -450,7 +452,7 @@
(#Cons [body
#Nil])])])))
#Nil])])])))
- (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])])))
+ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
#Nil])]))
(#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
@@ -482,28 +484,28 @@
))))
(_lux_declare-macro def')
-(def' #export (defmacro tokens)
+(def' (defmacro tokens)
Macro
(_lux_case tokens
(#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
- (return (#Cons [($form (#Cons [($symbol ["lux" "def'"])
- (#Cons [($form (#Cons [name args]))
- (#Cons [($symbol ["lux" "Macro"])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"])
+ (#Cons [(form$ (#Cons [name args]))
+ (#Cons [(symbol$ ["lux" "Macro"])
(#Cons [body
#Nil])])
])]))
- (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
+ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
#Nil])]))
(#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])])
- (return (#Cons [($form (#Cons [($symbol ["lux" "def'"])
- (#Cons [($tag ["" "export"])
- (#Cons [($form (#Cons [name args]))
- (#Cons [($symbol ["lux" "Macro"])
+ (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"])
+ (#Cons [(tag$ ["" "export"])
+ (#Cons [(form$ (#Cons [name args]))
+ (#Cons [(symbol$ ["lux" "Macro"])
(#Cons [body
#Nil])])
])])]))
- (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
+ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
#Nil])]))
_
@@ -585,7 +587,7 @@
_
(fail "Wrong syntax for $'")))
-(def' #export (foldL f init xs)
+(def' (foldL f init xs)
(All' [a b]
(->' (->' (B' a) (B' b) (B' a))
(B' a)
@@ -598,27 +600,14 @@
(#Cons [x xs'])
(foldL f (f init x) xs')))
-(def' #export (foldR f init xs)
- (All' [a b]
- (->' (->' (B' b) (B' a) (B' a))
- (B' a)
- ($' List (B' b))
- (B' a)))
- (_lux_case xs
- #Nil
- init
-
- (#Cons [x xs'])
- (f x (foldR f init xs'))))
-
-(def' #export (reverse list)
+(def' (reverse list)
(All' [a]
(->' ($' List (B' a)) ($' List (B' a))))
(foldL (lambda' [tail head] (#Cons [head tail]))
#Nil
list))
-(defmacro #export (list xs)
+(defmacro (list xs)
(return (#Cons [(foldL (lambda' [tail head]
(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"]))
(#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])])))
@@ -627,7 +616,7 @@
(reverse xs))
#Nil])))
-(defmacro #export (list& xs)
+(defmacro (list& xs)
(_lux_case (reverse xs)
(#Cons [last init])
(return (list (foldL (lambda' [tail head]
@@ -654,12 +643,12 @@
(fail "lambda requires a non-empty arguments tuple.")
(#Cons [harg targs])
- (return (list ($form (list ($symbol ["" "_lux_lambda"])
- ($symbol name)
+ (return (list (form$ (list (symbol$ ["" "_lux_lambda"])
+ (symbol$ name)
harg
(foldL (lambda' [body' arg]
- ($form (list ($symbol ["" "_lux_lambda"])
- ($symbol ["" ""])
+ (form$ (list (symbol$ ["" "_lux_lambda"])
+ (symbol$ ["" ""])
arg
body')))
body
@@ -673,39 +662,39 @@
(#Cons [(#Meta [_ (#TagS ["" "export"])])
(#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
(#Cons [type (#Cons [body #Nil])])])])
- (return (list ($form (list ($symbol ["" "_lux_def"])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
name
- ($form (list ($symbol ["" "_lux_:"])
+ (form$ (list (symbol$ ["" "_lux_:"])
type
- ($form (list ($symbol ["lux" "lambda"])
+ (form$ (list (symbol$ ["lux" "lambda"])
name
- ($tuple args)
+ (tuple$ args)
body))))))
- ($form (list ($symbol ["" "_lux_export"]) name))))
+ (form$ (list (symbol$ ["" "_lux_export"]) name))))
(#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
- (return (list ($form (list ($symbol ["" "_lux_def"])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
name
- ($form (list ($symbol ["" "_lux_:"])
+ (form$ (list (symbol$ ["" "_lux_:"])
type
body))))
- ($form (list ($symbol ["" "_lux_export"]) name))))
+ (form$ (list (symbol$ ["" "_lux_export"]) name))))
(#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
(#Cons [type (#Cons [body #Nil])])])
- (return (list ($form (list ($symbol ["" "_lux_def"])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
name
- ($form (list ($symbol ["" "_lux_:"])
+ (form$ (list (symbol$ ["" "_lux_:"])
type
- ($form (list ($symbol ["lux" "lambda"])
+ (form$ (list (symbol$ ["lux" "lambda"])
name
- ($tuple args)
+ (tuple$ args)
body))))))))
(#Cons [name (#Cons [type (#Cons [body #Nil])])])
- (return (list ($form (list ($symbol ["" "_lux_def"])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
name
- ($form (list ($symbol ["" "_lux_:"]) type body))))))
+ (form$ (list (symbol$ ["" "_lux_:"]) type body))))))
_
(fail "Wrong syntax for def")
@@ -729,16 +718,14 @@
(lambda [body binding]
(_lux_case binding
[label value]
- (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body))))))
+ (form$ (list (symbol$ ["" "_lux_case"]) value label body)))))
body
- (foldL (lambda [tail head] (#Cons [head tail]))
- #Nil
- (as-pairs bindings)))))
+ (reverse (as-pairs bindings)))))
_
(fail "Wrong syntax for let")))
-(def'' #export (map f xs)
+(def'' (map f xs)
(All' [a b]
(->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b))))
(_lux_case xs
@@ -748,7 +735,7 @@
(#Cons [x xs'])
(#Cons [(f x) (map f xs')])))
-(def'' #export (any? p xs)
+(def'' (any? p xs)
(All' [a]
(->' (->' (B' a) Bool) ($' List (B' a)) Bool))
(_lux_case xs
@@ -785,7 +772,7 @@
(_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
(_meta (#TupleS (list token (untemplate-list tokens')))))))))
-(def'' (list:++ xs ys)
+(def'' #export (list:++ xs ys)
(All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a))))
(_lux_case xs
(#Cons [x xs'])
@@ -797,7 +784,7 @@
(defmacro #export ($ tokens)
(_lux_case tokens
(#Cons [op (#Cons [init args])])
- (return (list (foldL (lambda [a1 a2] ($form (list op a1 a2)))
+ (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2)))
init
args)))
@@ -814,35 +801,36 @@
spliced
_
- ($form (list ($symbol ["" "_lux_:"])
- ($symbol ["lux" "SyntaxList"])
- ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))
+ (form$ (list (symbol$ ["" "_lux_:"])
+ (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
+ (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
+ (tag$ ["lux" "Nil"])))))))))
elems)]
- (wrap-meta ($form (list tag
- ($form (list& ($symbol ["lux" "$"])
- ($symbol ["lux" "list:++"])
+ (wrap-meta (form$ (list tag
+ (form$ (list& (symbol$ ["lux" "$"])
+ (symbol$ ["lux" "list:++"])
elems'))))))
false
- (wrap-meta ($form (list tag (untemplate-list (map untemplate elems)))))))
+ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
(def'' (untemplate subst token)
(->' Text Syntax Syntax)
(_lux_case token
(#Meta [_ (#BoolS value)])
- (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value)))))
+ (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))
(#Meta [_ (#IntS value)])
- (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value)))))
+ (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))
(#Meta [_ (#RealS value)])
- (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value)))))
+ (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))
(#Meta [_ (#CharS value)])
- (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value)))))
+ (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))
(#Meta [_ (#TextS value)])
- (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value)))))
+ (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))
(#Meta [_ (#TagS [module name])])
(let [module' (_lux_case module
@@ -851,7 +839,7 @@
_
module)]
- (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name)))))))
+ (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))
(#Meta [_ (#SymbolS [module name])])
(let [module' (_lux_case module
@@ -860,23 +848,23 @@
_
module)]
- (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name)))))))
+ (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name)))))))
(#Meta [_ (#TupleS elems)])
- (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems)
+ (splice (untemplate subst) (tag$ ["lux" "TupleS"]) elems)
(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])
unquoted
(#Meta [_ (#FormS elems)])
- (splice (untemplate subst) ($tag ["lux" "FormS"]) elems)
+ (splice (untemplate subst) (tag$ ["lux" "FormS"]) elems)
(#Meta [_ (#RecordS fields)])
- (wrap-meta ($form (list ($tag ["lux" "RecordS"])
+ (wrap-meta (form$ (list (tag$ ["lux" "RecordS"])
(untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax)
(lambda [kv]
(let [[k v] kv]
- ($tuple (list (untemplate subst k) (untemplate subst v))))))
+ (tuple$ (list (untemplate subst k) (untemplate subst v))))))
fields)))))
))
@@ -893,8 +881,11 @@
(#Cons [init apps])
(return (list (foldL (lambda [acc app]
(_lux_case app
+ (#Meta [_ (#TupleS parts)])
+ (tuple$ (list:++ parts (list acc)))
+
(#Meta [_ (#FormS parts)])
- ($form (list:++ parts (list acc)))
+ (form$ (list:++ parts (list acc)))
_
(`' ((~ app) (~ acc)))))
@@ -982,7 +973,7 @@
(fail "Wrong syntax for ->")))
(defmacro #export (, tokens)
- (return (list (`' (#;TupleT (;list (~@ tokens)))))))
+ (return (list (`' (#;TupleT (~ (untemplate-list tokens)))))))
(defmacro (do tokens)
(_lux_case tokens
@@ -995,7 +986,7 @@
(`' (;let (~ value) (~ body')))
_
- (`' (;bind (_lux_lambda (~ ($symbol ["" ""]))
+ (`' (;bind (_lux_lambda (~ (symbol$ ["" ""]))
(~ var)
(~ body'))
(~ value)))))))
@@ -1066,7 +1057,7 @@
_
#Nil))
-(def'' (text:= x y)
+(def'' #export (text:= x y)
(-> Text Text Bool)
(_jvm_invokevirtual java.lang.Object equals [java.lang.Object]
x [y]))
@@ -1094,13 +1085,13 @@
template)
(#Meta [_ (#TupleS elems)])
- ($tuple (map (apply-template env) elems))
+ (tuple$ (map (apply-template env) elems))
(#Meta [_ (#FormS elems)])
- ($form (map (apply-template env) elems))
+ (form$ (map (apply-template env) elems))
(#Meta [_ (#RecordS members)])
- ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
+ (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax))
(lambda [kv]
(let [[slot value] kv]
[(apply-template env slot) (apply-template env value)])))
@@ -1133,7 +1124,7 @@
return))
_
- (fail "All the do-template bindigns must be symbols."))
+ (fail "Wrong syntax for do-template"))
_
(fail "Wrong syntax for do-template")))
@@ -1151,6 +1142,19 @@
[real:< _jvm_dlt Real]
)
+(do-template [<name> <cmp> <eq> <type>]
+ [(def'' #export (<name> x y)
+ (-> <type> <type> Bool)
+ (if (<cmp> x y)
+ true
+ (<eq> x y)))]
+
+ [ int:>= int:> int:= Int]
+ [ int:<= int:< int:= Int]
+ [real:>= real:> real:= Real]
+ [real:<= real:< real:= Real]
+ )
+
(do-template [<name> <cmp> <type>]
[(def'' #export (<name> x y)
(-> <type> <type> <type>)
@@ -1172,7 +1176,7 @@
(-> Int Int Bool)
(int:= 0 (int:% n div)))
-(def'' #export (length list)
+(def'' (length list)
(-> List Int)
(foldL (lambda [acc _] (int:+ 1 acc)) 0 list))
@@ -1236,13 +1240,14 @@
(#Cons [harg targs])
(let [replacements (map (_lux_: (-> Text (, Text Syntax))
- (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))]))
+ (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))]))
(list& self-ident idents))
body' (foldL (lambda [body' arg']
- (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))
+ (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')])))
(replace-syntax replacements body)
(reverse targs))]
- (return (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))
+ ## (#;Some #;Nil)
+ (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')]))))))
#None
(fail "'All' arguments must be symbols."))
@@ -1263,7 +1268,19 @@
#Nil
#None))
-(def'' #export (get-module-name state)
+(def'' (put k v dict)
+ (All [a]
+ (-> Text a ($' List (, Text a)) ($' List (, Text a))))
+ (_lux_case dict
+ #Nil
+ (list [k v])
+
+ (#Cons [[k' v'] dict'])
+ (if (text:= k k')
+ (#Cons [[k' v] dict'])
+ (#Cons [[k' v'] (put k v dict')]))))
+
+(def'' (get-module-name state)
($' Lux Text)
(_lux_case state
{#source source #modules modules
@@ -1298,7 +1315,7 @@
_
#None)))
-(def'' #export (find-macro ident)
+(def'' (find-macro ident)
(-> Ident ($' Lux ($' Maybe Macro)))
(do Lux:Monad
[current-module get-module-name]
@@ -1315,7 +1332,7 @@
(-> ($' List ($' List a)) ($' List a)))
(foldL list:++ #Nil xs))
-(def'' #export (normalize ident)
+(def'' (normalize ident)
(-> Ident ($' Lux Ident))
(_lux_case ident
["" name]
@@ -1335,17 +1352,17 @@
(#Meta [_ (#TagS ident)])
(do Lux:Monad
[ident (normalize ident)]
- (;return (`' [(~ ($text (ident->text ident))) (;,)])))
+ (;return (`' [(~ (text$ (ident->text ident))) (;,)])))
(#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))])
(do Lux:Monad
[ident (normalize ident)]
- (;return (`' [(~ ($text (ident->text ident))) (~ value)])))
+ (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
_
(fail "Wrong syntax for |"))))
tokens)]
- (;return (list (`' (#;VariantT (;list (~@ pairs))))))))
+ (;return (list (`' (#;VariantT (~ (untemplate-list pairs))))))))
(defmacro #export (& tokens)
(if (not (multiple? 2 (length tokens)))
@@ -1358,18 +1375,18 @@
[(#Meta [_ (#TagS ident)]) value]
(do Lux:Monad
[ident (normalize ident)]
- (;return (`' [(~ ($text (ident->text ident))) (~ value)])))
+ (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
_
(fail "Wrong syntax for &"))))
(as-pairs tokens))]
- (;return (list (`' (#;RecordT (;list (~@ pairs)))))))))
+ (;return (list (`' (#;RecordT (~ (untemplate-list pairs)))))))))
-(def'' #export (->text x)
+(def'' (->text x)
(-> (^ java.lang.Object) Text)
(_jvm_invokevirtual java.lang.Object toString [] x []))
-(def'' #export (interpose sep xs)
+(def'' (interpose sep xs)
(All [a]
(-> a ($' List a) ($' List a)))
(_lux_case xs
@@ -1382,49 +1399,7 @@
(#Cons [x xs'])
(list& x sep (interpose sep xs'))))
-(def'' #export (syntax:show syntax)
- (-> Syntax Text)
- (_lux_case syntax
- (#Meta [_ (#BoolS value)])
- (->text value)
-
- (#Meta [_ (#IntS value)])
- (->text value)
-
- (#Meta [_ (#RealS value)])
- (->text value)
-
- (#Meta [_ (#CharS value)])
- ($ text:++ "#\"" (->text value) "\"")
-
- (#Meta [_ (#TextS value)])
- value
-
- (#Meta [_ (#SymbolS ident)])
- (ident->text ident)
-
- (#Meta [_ (#TagS ident)])
- (text:++ "#" (ident->text ident))
-
- (#Meta [_ (#TupleS members)])
- ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]")
-
- (#Meta [_ (#FormS members)])
- ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")")
-
- (#Meta [_ (#RecordS slots)])
- ($ text:++ "{"
- (|> slots
- (map (_lux_: (-> (, Syntax Syntax) Text)
- (lambda [slot]
- (let [[k v] slot]
- ($ text:++ (syntax:show k) " " (syntax:show v))))))
- (interpose " ")
- (foldL text:++ ""))
- "}")
- ))
-
-(def'' #export (macro-expand syntax)
+(def'' (macro-expand syntax)
(-> Syntax ($' Lux ($' List Syntax)))
(_lux_case syntax
(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))])
@@ -1440,19 +1415,19 @@
#None
(do Lux:Monad
- [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))]
- (;return (list ($form (list:join parts')))))))
+ [parts' (map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))]
+ (;return (list (form$ (list:join parts')))))))
(#Meta [_ (#FormS (#Cons [harg targs]))])
(do Lux:Monad
[harg+ (macro-expand harg)
targs+ (map% Lux:Monad macro-expand targs)]
- (;return (list ($form (list:++ harg+ (list:join targs+))))))
+ (;return (list (form$ (list:++ harg+ (list:join targs+))))))
(#Meta [_ (#TupleS members)])
(do Lux:Monad
[members' (map% Lux:Monad macro-expand members)]
- (;return (list ($tuple (list:join members')))))
+ (;return (list (tuple$ (list:join members')))))
_
(return (list syntax))))
@@ -1461,10 +1436,10 @@
(-> Syntax Syntax)
(_lux_case type
(#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))])
- ($form (#Cons [($tag tag) (map walk-type parts)]))
+ (form$ (#Cons [(tag$ tag) (map walk-type parts)]))
(#Meta [_ (#TupleS members)])
- ($tuple (map walk-type members))
+ (tuple$ (map walk-type members))
(#Meta [_ (#FormS (#Cons [type-fn args]))])
(foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))
@@ -1474,7 +1449,7 @@
_
type))
-(defmacro #export (type` tokens)
+(defmacro #export (type tokens)
(_lux_case tokens
(#Cons [type #Nil])
(do Lux:Monad
@@ -1484,15 +1459,15 @@
(;return (list (walk-type type')))
_
- (fail "type`: The expansion of the type-syntax had to yield a single element.")))
+ (fail "The expansion of the type-syntax had to yield a single element.")))
_
- (fail "Wrong syntax for type`")))
+ (fail "Wrong syntax for type")))
(defmacro #export (: tokens)
(_lux_case tokens
(#Cons [type (#Cons [value #Nil])])
- (return (list (`' (_lux_: (;type` (~ type)) (~ value)))))
+ (return (list (`' (_lux_: (;type (~ type)) (~ value)))))
_
(fail "Wrong syntax for :")))
@@ -1500,7 +1475,7 @@
(defmacro #export (:! tokens)
(_lux_case tokens
(#Cons [type (#Cons [value #Nil])])
- (return (list (`' (_lux_:! (;type` (~ type)) (~ value)))))
+ (return (list (`' (_lux_:! (;type (~ type)) (~ value)))))
_
(fail "Wrong syntax for :!")))
@@ -1516,10 +1491,10 @@
parts (: (Maybe (, Syntax (List Syntax) Syntax))
(_lux_case tokens'
(#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])])
- (#Some [($symbol name) #Nil type])
+ (#Some [(symbol$ name) #Nil type])
(#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])])
- (#Some [($symbol name) args type])
+ (#Some [(symbol$ name) args type])
_
#None))]
@@ -1536,29 +1511,17 @@
_
(`' (;All (~ name) [(~@ args)] (~ type)))))]
- (return (list& (`' (_lux_def (~ name) (;type` (~ type'))))
+ (return (list& (`' (_lux_def (~ name) (;type (~ type'))))
with-export)))
#None
(fail "Wrong syntax for deftype"))
))
-(deftype #export (IO a)
- (-> (,) a))
-
-(defmacro #export (io tokens)
- (_lux_case tokens
- (#Cons [value #Nil])
- (let [blank ($symbol ["" ""])]
- (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value))))))
-
- _
- (fail "Wrong syntax for io")))
-
(defmacro #export (exec tokens)
(_lux_case (reverse tokens)
(#Cons [value actions])
- (let [dummy ($symbol ["" ""])]
+ (let [dummy (symbol$ ["" ""])]
(return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))
value
actions))))
@@ -1626,16 +1589,16 @@
[expansions (map% Lux:Monad
(: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax))))
(lambda expander [branch]
- (let [[pattern body] branch]
- (_lux_case pattern
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))])
- (do Lux:Monad
- [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args)))
- expansions (map% Lux:Monad expander (as-pairs expansion))]
- (;return (list:join expansions)))
-
- _
- (;return (list branch))))))
+ (let [[pattern body] branch]
+ (_lux_case pattern
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))])
+ (do Lux:Monad
+ [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args)))
+ expansions (map% Lux:Monad expander (as-pairs expansion))]
+ (;return (list:join expansions)))
+
+ _
+ (;return (list branch))))))
(as-pairs branches))]
(;return (list (`' (_lux_case (~ value)
(~@ (|> expansions list:join (map rejoin-pair) list:join)))))))
@@ -1680,11 +1643,6 @@
[inc 1]
[dec -1])
-(def (int:show int)
- (-> Int Text)
- (_jvm_invokevirtual java.lang.Object toString []
- int []))
-
(defmacro #export (` tokens)
(do Lux:Monad
[module-name get-module-name]
@@ -1695,7 +1653,7 @@
_
(fail "Wrong syntax for `"))))
-(def #export (gensym prefix state)
+(def (gensym prefix state)
(-> Text (Lux Syntax))
(case state
{#source source #modules modules
@@ -1704,9 +1662,9 @@
(#Right [{#source source #modules modules
#envs envs #types types #host host
#seed (inc seed) #seen-sources seen-sources #eval? eval?}
- ($symbol ["__gensym__" (int:show seed)])])))
+ (symbol$ ["__gensym__" (->text seed)])])))
-(def #export (macro-expand-1 token)
+(def (macro-expand-1 token)
(-> Syntax (Lux Syntax))
(do Lux:Monad
[token+ (macro-expand token)]
@@ -1719,7 +1677,7 @@
(defmacro #export (sig tokens)
(do Lux:Monad
- [tokens' (map% Lux:Monad macro-expand-1 tokens)
+ [tokens' (map% Lux:Monad macro-expand tokens)
members (map% Lux:Monad
(: (-> Syntax (Lux (, Ident Syntax)))
(lambda [token]
@@ -1731,13 +1689,13 @@
_
(fail "Signatures require typed members!"))))
- tokens')]
- (;return (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax)
- (lambda [pair]
- (let [[name type] pair]
- (`' [(~ (|> name ident->text $text))
- (~ type)]))))
- members)))))))))
+ (list:join tokens'))]
+ (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax)
+ (lambda [pair]
+ (let [[name type] pair]
+ (`' [(~ (|> name ident->text text$))
+ (~ type)]))))
+ members)))))))))
(defmacro #export (defsig tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
@@ -1776,7 +1734,7 @@
(defmacro #export (struct tokens)
(do Lux:Monad
- [tokens' (map% Lux:Monad macro-expand-1 tokens)
+ [tokens' (map% Lux:Monad macro-expand tokens)
members (map% Lux:Monad
(: (-> Syntax (Lux (, Syntax Syntax)))
(lambda [token]
@@ -1784,12 +1742,12 @@
(\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))]))
(do Lux:Monad
[name' (normalize name)]
- (;return (: (, Syntax Syntax) [($tag name') value])))
+ (;return (: (, Syntax Syntax) [(tag$ name') value])))
_
(fail "Structures require defined members!"))))
- tokens')]
- (;return (list ($record members)))))
+ (list:join tokens'))]
+ (;return (list (record$ members)))))
(defmacro #export (defstruct tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
@@ -1824,48 +1782,12 @@
#Nil))))
#None
- (fail "Wrong syntax for defsig"))))
-
-(defsig #export (Eq a)
- (: (-> a a Bool)
- =))
-
-(do-template [<name> <type> <test>]
- [(defstruct #export <name> (Eq <type>)
- (def (= x y)
- (<test> x y)))]
-
- [Int:Eq Int _jvm_leq]
- [Real:Eq Real _jvm_deq])
+ (fail "Wrong syntax for defstruct"))))
(def #export (id x)
(All [a] (-> a a))
x)
-(defsig #export (Show a)
- (: (-> a Text)
- show))
-
-(do-template [<name> <type> <body>]
- [(defstruct #export <name> (Show <type>)
- (def (show x)
- <body>))]
-
- [Bool:Show Bool (->text x)]
- [Int:Show Int (->text x)]
- [Real:Show Real (->text x)]
- [Char:Show Char ($ text:++ "#\"" (->text x) "\"")])
-
-(defsig #export (Ord a)
- (: (-> a a Bool)
- <)
- (: (-> a a Bool)
- <=)
- (: (-> a a Bool)
- >)
- (: (-> a a Bool)
- >=))
-
(do-template [<name> <form> <message>]
[(defmacro #export (<name> tokens)
(case (reverse tokens)
@@ -1877,80 +1799,152 @@
_
(fail <message>)))]
- [and (if (~ pre) true (~ post)) "and requires >=1 clauses."]
- [or (if (~ pre) (~ post) false) "or requires >=1 clauses."])
-
-(do-template [<name> <type> <lt> <gt> <eq>]
- [(defstruct #export <name> (Ord <type>)
- (def (< x y)
- (<lt> x y))
-
- (def (<= x y)
- (or (<lt> x y)
- (<eq> x y)))
-
- (def (> x y)
- (<gt> x y))
-
- (def (>= x y)
- (or (<gt> x y)
- (<eq> x y))))]
-
- [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq]
- [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq])
-
-(defmacro #export (lux tokens state)
+ [and (if (~ pre) (~ post) false) "and requires >=1 clauses."]
+ [or (if (~ pre) true (~ post)) "or requires >=1 clauses."])
+
+(deftype Referrals
+ (| #All
+ (#Only (List Text))
+ (#Except (List Text))
+ #Nothing))
+
+(deftype Import
+ (, Text (Maybe Text) Referrals))
+
+(def (extract-defs defs)
+ (-> (List Syntax) (Lux (List Text)))
+ (map% Lux:Monad
+ (: (-> Syntax (Lux Text))
+ (lambda [def]
+ (case def
+ (#Meta [_ (#SymbolS ["" name])])
+ (return name)
+
+ _
+ (fail "only/except requires symbols."))))
+ defs))
+
+(def (parse-alias tokens)
+ (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax))))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens'))
+ (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens']))
+
+ _
+ (return (: (, (Maybe Text) (List Syntax)) [#None tokens]))))
+
+(def (parse-referrals tokens)
+ (-> (List Syntax) (Lux (, Referrals (List Syntax))))
+ (case tokens
+ (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens'))
+ (case referral
+ (#Meta [_ (#TagS ["" "all"])])
+ (return (: (, Referrals (List Syntax)) [#All tokens']))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))]))
+ (do Lux:Monad
+ [defs' (extract-defs defs)]
+ (return (: (, Referrals (List Syntax)) [(#Only defs') tokens'])))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "except"])]) defs))]))
+ (do Lux:Monad
+ [defs' (extract-defs defs)]
+ (return (: (, Referrals (List Syntax)) [(#Except defs') tokens'])))
+
+ _
+ (fail "Incorrect syntax for referral."))
+
+ _
+ (return (: (, Referrals (List Syntax)) [#Nothing tokens]))))
+
+(def (decorate-imports super-name tokens)
+ (-> Text (List Syntax) (Lux (List Syntax)))
+ (map% Lux:Monad
+ (: (-> Syntax (Lux Syntax))
+ (lambda [token]
+ (case token
+ (#Meta [_ (#SymbolS ["" sub-name])])
+ (return (symbol$ ["" ($ text:++ super-name "/" sub-name)]))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))]))
+ (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts)))
+
+ _
+ (fail "Wrong import syntax."))))
+ tokens))
+
+(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'))))
+
+(def (module-exists? module state)
+ (-> Text (Lux Bool))
(case state
{#source source #modules modules
- #envs envs #types types #host host
+ #envs envs #types types #host host
#seed seed #seen-sources seen-sources #eval? eval?}
- (case (get "lux" modules)
- (#Some lux)
+ (case (get module modules)
+ (#Some =module)
+ (#Right [state true])
+
+ #None
+ (#Right [state false]))
+ ))
+
+(def (exported-defs module state)
+ (-> Text (Lux (List Text)))
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?}
+ (case (get module modules)
+ (#Some =module)
(let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
(List Text))
(lambda [gdef]
(let [[name [export? _]] gdef]
(if export?
- (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
- (_jvm_getstatic java.lang.System out) [($ text:++ "Importing: " name "\n")])
- (list name))
+ (list name)
(list)))))
- (let [{#module-aliases _ #defs defs #imports _} lux]
+ (let [{#module-aliases _ #defs defs #imports _} =module]
defs))]
- (#Right [state (map (lambda [name]
- (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))
- (list:join to-alias))]))
+ (#Right [state (list:join to-alias)]))
#None
- (#Left "Uh, oh... The universe is not working properly..."))
+ (#Left ($ text:++ "Unknown module: " module)))
))
-(def #export (print x)
- (-> Text (IO (,)))
- (lambda [_]
- (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
- (_jvm_getstatic java.lang.System out) [x])
- [])))
-
-(def #export (println x)
- (-> Text (IO (,)))
- (print (text:++ x "\n")))
-
-(def #export (some f xs)
- (All [a b]
- (-> (-> a (Maybe b)) (List a) (Maybe b)))
- (case xs
- #Nil
- #None
-
- (#Cons [x xs'])
- (case (f x)
- #None
- (some f xs')
-
- (#Some y)
- (#Some y))))
-
+(def (last-index-of part text)
+ (-> Text Text Int)
+ (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String]
+ text [part])))
(def (index-of part text)
(-> Text Text Int)
@@ -1967,6 +1961,177 @@
(_jvm_invokevirtual java.lang.String substring [int int]
text [(_jvm_l2i idx1) (_jvm_l2i idx2)]))
+(def (split-module-contexts module)
+ (-> Text (List Text))
+ (#Cons [module (let [idx (last-index-of "/" module)]
+ (if (int:< idx 0)
+ #Nil
+ (split-module-contexts (substring2 0 idx module))))]))
+
+(def (split-module module)
+ (-> Text (List Text))
+ (let [idx (index-of "/" module)]
+ (if (int:< idx 0)
+ (#Cons [module #Nil])
+ (#Cons [(substring2 0 idx module)
+ (split-module (substring1 (inc idx) module))]))))
+
+(def (@ idx xs)
+ (All [a]
+ (-> Int (List a) (Maybe a)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons [x xs'])
+ (if (int:= idx 0)
+ (#Some x)
+ (@ (dec idx) xs')
+ )))
+
+(def (split-with' p ys xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a) (, (List a) (List a))))
+ (case xs
+ #Nil
+ [ys xs]
+
+ (#Cons [x xs'])
+ (if (p x)
+ (split-with' p (list& x ys) xs')
+ [ys xs])))
+
+(def (split-with p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (, (List a) (List a))))
+ (let [[ys' xs'] (split-with' p #Nil xs)]
+ [(reverse ys') xs']))
+
+(def (clean-module module)
+ (-> Text (Lux Text))
+ (do Lux:Monad
+ [module-name get-module-name]
+ (case (split-module module)
+ (\ (list& "." parts))
+ (return (|> (list& module-name parts) (interpose "/") (foldL text:++ "")))
+
+ parts
+ (let [[ups parts'] (split-with (text:= "..") parts)
+ num-ups (length ups)]
+ (if (int:= num-ups 0)
+ (return module)
+ (case (@ num-ups (split-module-contexts module-name))
+ #None
+ (fail (text:++ "Can't clean module: " module))
+
+ (#Some top-module)
+ (return (|> (list& top-module parts') (interpose "/") (foldL text:++ ""))))
+ )))
+ ))
+
+(def (filter p xs)
+ (All [a] (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ (list)
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (#;Cons [x (filter p xs')])
+ (filter p xs'))))
+
+(def (is-member? cases name)
+ (-> (List Text) Text Bool)
+ (let [output (foldL (lambda [prev case]
+ (or prev
+ (text:= case name)))
+ false
+ cases)]
+ output))
+
+(defmacro #export (import tokens)
+ (do Lux:Monad
+ [imports (parse-imports tokens)
+ imports (map% Lux:Monad
+ (: (-> Import (Lux Import))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals]
+ (do Lux:Monad
+ [m-name (clean-module m-name)]
+ (;return (: Import [m-name m-alias m-referrals]))))))
+ imports)
+ unknowns' (map% Lux:Monad
+ (: (-> Import (Lux (List Text)))
+ (lambda [import]
+ (case import
+ [m-name _ _]
+ (do Lux:Monad
+ [? (module-exists? m-name)]
+ (;return (if ?
+ (list)
+ (list m-name)))))))
+ imports)
+ #let [unknowns (list:join unknowns')]]
+ (case unknowns
+ #Nil
+ (do Lux:Monad
+ [output' (map% Lux:Monad
+ (: (-> Import (Lux (List Syntax)))
+ (lambda [import]
+ (case import
+ [m-name m-alias m-referrals]
+ (do Lux:Monad
+ [defs (case m-referrals
+ #All
+ (exported-defs m-name)
+
+ (#Only +defs)
+ (do Lux:Monad
+ [*defs (exported-defs m-name)]
+ (;return (filter (is-member? +defs) *defs)))
+
+ (#Except -defs)
+ (do Lux:Monad
+ [*defs (exported-defs m-name)]
+ (;return (filter (. not (is-member? -defs)) *defs)))
+
+ #Nothing
+ (;return (list)))]
+ (;return ($ list:++
+ (list (` (_lux_import (~ (text$ m-name)))))
+ (case m-alias
+ #None (list)
+ (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))
+ (map (: (-> Text Syntax)
+ (lambda [def]
+ (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def]))))))
+ defs)))))))
+ imports)]
+ (;return (list:join output')))
+
+ _
+ (;return (: (List Syntax)
+ (list:++ (map (lambda [m-name]
+ (` (_lux_import (~ (text$ m-name)))))
+ unknowns)
+ (list (` (import (~@ tokens))))))))))
+
+(def (some f xs)
+ (All [a b]
+ (-> (-> a (Maybe b)) (List a) (Maybe b)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons [x xs'])
+ (case (f x)
+ #None
+ (some f xs')
+
+ (#Some y)
+ (#Some y))))
+
(def (split-slot slot)
(-> Text (, Text Text))
(let [idx (index-of ";" slot)
@@ -1974,6 +2139,154 @@
name (substring1 (inc idx) slot)]
[module name]))
+(def (type:show type)
+ (-> Type Text)
+ (case type
+ (#DataT name)
+ ($ text:++ "(^ " name ")")
+
+ (#TupleT elems)
+ (case elems
+ #;Nil
+ "(,)"
+
+ _
+ ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")"))
+
+ (#VariantT cases)
+ (case cases
+ #;Nil
+ "(|)"
+
+ _
+ ($ text:++ "(| "
+ (|> cases
+ (map (: (-> (, Text Type) Text)
+ (lambda [kv]
+ (case kv
+ [k (#TupleT #;Nil)]
+ ($ text:++ "#" k)
+
+ [k v]
+ ($ text:++ "(#" k " " (type:show v) ")")))))
+ (interpose " ")
+ (foldL text:++ ""))
+ ")"))
+
+ (#RecordT fields)
+ (case fields
+ #;Nil
+ "(&)"
+
+ _
+ ($ text:++ "(& "
+ (|> fields
+ (map (: (-> (, Text Type) Text)
+ (: (-> (, Text Type) Text)
+ (lambda [kv]
+ (let [[k v] kv]
+ ($ text:++ "(#" k " " (type:show v) ")"))))))
+ (interpose " ")
+ (foldL text:++ ""))
+ ")"))
+
+ (#LambdaT [input output])
+ ($ text:++ "(-> " (type:show input) " " (type:show output) ")")
+
+ (#VarT id)
+ ($ text:++ "⌈" (->text id) "⌋")
+
+ (#BoundT name)
+ name
+
+ (#ExT ?id)
+ ($ text:++ "⟨" (->text ?id) "⟩")
+
+ (#AppT [?lambda ?param])
+ ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")")
+
+ (#AllT [?env ?name ?arg ?body])
+ ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")")
+ ))
+
+(def (beta-reduce env type)
+ (-> (List (, Text Type)) Type Type)
+ (case type
+ (#VariantT ?cases)
+ (#VariantT (map (: (-> (, Text Type) (, Text Type))
+ (lambda [kv]
+ (let [[k v] kv]
+ [k (beta-reduce env v)])))
+ ?cases))
+
+ (#RecordT ?fields)
+ (#RecordT (map (: (-> (, Text Type) (, Text Type))
+ (lambda [kv]
+ (let [[k v] kv]
+ [k (beta-reduce env v)])))
+ ?fields))
+
+ (#TupleT ?members)
+ (#TupleT (map (beta-reduce env) ?members))
+
+ (#AppT [?type-fn ?type-arg])
+ (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)])
+
+ (#AllT [?local-env ?local-name ?local-arg ?local-def])
+ (case ?local-env
+ #None
+ (#AllT [(#Some env) ?local-name ?local-arg ?local-def])
+
+ (#Some _)
+ type)
+
+ (#LambdaT [?input ?output])
+ (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)])
+
+ (#BoundT ?name)
+ (case (get ?name env)
+ (#Some bound)
+ bound
+
+ _
+ type)
+
+ _
+ type
+ ))
+
+(defmacro #export (? tokens)
+ (case tokens
+ (\ (list maybe else))
+ (do Lux:Monad
+ [g!value (gensym "")]
+ (return (list (` (case (~ maybe)
+ (#;Some (~ g!value))
+ (~ g!value)
+
+ _
+ (~ else))))))
+
+ _
+ (fail "Wrong syntax for ?")))
+
+(def (apply-type type-fn param)
+ (-> Type Type (Maybe Type))
+ (case type-fn
+ (#AllT [env name arg body])
+ (#Some (beta-reduce (|> (? env (list))
+ (put name type-fn)
+ (put arg param))
+ body))
+
+ (#AppT [F A])
+ (do Maybe:Monad
+ [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ _
+ #None))
+
(def (resolve-struct-type type)
(-> Type (Maybe Type))
(case type
@@ -1981,7 +2294,7 @@
(#Some type)
(#AppT [fun arg])
- (resolve-struct-type fun)
+ (apply-type fun arg)
(#AllT [_ _ _ body])
(resolve-struct-type body)
@@ -1989,55 +2302,160 @@
_
#None))
-(defmacro #export (using tokens state)
+(def (try-both f x1 x2)
+ (All [a b]
+ (-> (-> a (Maybe b)) a a (Maybe b)))
+ (case (f x1)
+ #;None (f x2)
+ (#;Some y) (#;Some y)))
+
+(def (try-both% x1 x2)
+ (All [a b]
+ (-> (Maybe a) (Maybe a) (Maybe a)))
+ (case x1
+ #;None x2
+ (#;Some _) x1))
+
+(def (find-in-env name state)
+ (-> Ident Compiler (Maybe Type))
+ (let [vname' (ident->text name)]
+ (case state
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?}
+ (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
+ (lambda [env]
+ (case env
+ {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}}
+ (try-both% (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+ (lambda [binding]
+ (let [[bname [_ type]] binding]
+ (if (text:= vname' bname)
+ (#Some type)
+ #None))))
+ locals)
+ (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+ (lambda [binding]
+ (let [[bname [_ type]] binding]
+ (if (text:= vname' bname)
+ (#Some type)
+ #None))))
+ closure))
+ ## (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
+ ## (lambda [binding]
+ ## (let [[bname [_ type]] binding]
+ ## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
+ ## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-env #2: " bname "\n")])
+ ## (if (text:= vname' bname)
+ ## (#Some type)
+ ## #None)))))
+ ## locals)
+ )))
+ envs))))
+
+(def (show-envs envs)
+ (-> (List (Env Text (, LuxVar Type))) Text)
+ (|> envs
+ (map (lambda [env]
+ (case env
+ {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _}
+ ($ text:++ name ": " (|> locals
+ (map (: (All [a] (-> (, Text a) Text))
+ (lambda [b] (let [[label _] b] label))))
+ (interpose " ")
+ (foldL text:++ ""))))))
+ (interpose "\n")
+ (foldL text:++ "")))
+
+(def (find-in-defs name state)
+ (-> Ident Compiler (Maybe Type))
+ (let [[v-prefix v-name] name
+ {#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?} state]
+ (case (get v-prefix modules)
+ #None
+ #None
+
+ (#Some {#defs defs #module-aliases _ #imports _})
+ (case (get v-name defs)
+ #None
+ #None
+
+ (#Some [_ def-data])
+ (case def-data
+ #TypeD (#Some Type)
+ (#ValueD type) (#Some type)
+ (#MacroD m) (#Some Macro)
+ (#AliasD name') (find-in-defs name' state))))))
+## (def (find-in-defs name state)
+## (-> Ident Compiler (Maybe Type))
+## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
+## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")])
+## (let [[v-prefix v-name] name
+## {#source source #modules modules
+## #envs envs #types types #host host
+## #seed seed #seen-sources seen-sources #eval? eval?} state]
+## (do Maybe:Monad
+## [module (get v-prefix modules)
+## #let [{#defs defs #module-aliases _ #imports _} module]
+## def (get v-name defs)
+## #let [[_ def-data] def]]
+## (case def-data
+## #TypeD (;return Type)
+## (#ValueD type) (;return type)
+## (#MacroD m) (;return Macro)
+## (#AliasD name') (find-in-defs name' state))))))
+
+(def (find-var-type name)
+ (-> Ident (Lux Type))
+ (do Lux:Monad
+ [name' (normalize name)]
+ (lambda [state]
+ (case (find-in-env name state)
+ (#Some struct-type)
+ (#Right [state struct-type])
+
+ _
+ (case (find-in-defs name' state)
+ (#Some struct-type)
+ (#Right [state struct-type])
+
+ _
+ (let [{#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #seen-sources seen-sources #eval? eval?} state]
+ (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))))
+
+(defmacro #export (using tokens)
(case tokens
(\ (list struct body))
(case struct
- (#Meta [_ (#SymbolS vname)])
- (let [vname' (ident->text vname)]
- (case state
- {#source source #modules modules
- #envs envs #types types #host host
- #seed seed #seen-sources seen-sources #eval? eval?}
- (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
- (lambda [env]
- (case env
- {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _}
- (some (: (-> (, Text (, LuxVar Type)) (Maybe Type))
- (lambda [binding]
- (let [[bname [_ type]] binding]
- (if (text:= vname' bname)
- (#Some type)
- #None))))
- mappings))))
- envs)]
- (case ?struct-type
- #None
- (#Left ($ text:++ "Unknown structure: " vname'))
-
- (#Some struct-type)
- (case (resolve-struct-type struct-type)
- (#Some (#RecordT slots))
- (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax))
- (lambda [slot]
- (let [[sname stype] slot
- [module name] (split-slot sname)]
- [($tag [module name]) ($symbol ["" name])])))
- slots))]
- (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))]))
-
- _
- (#Left "Can only \"use\" records."))))))
+ (#Meta [_ (#SymbolS name)])
+ (do Lux:Monad
+ [struct-type (find-var-type name)]
+ (case (resolve-struct-type struct-type)
+ (#Some (#RecordT slots))
+ (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[sname stype] slot
+ full-name (split-slot sname)]
+ [(tag$ full-name) (symbol$ full-name)])))
+ slots))]
+ (return (list (` (_lux_case (~ struct) (~ pattern) (~ body))))))
+ _
+ (fail "Can only \"use\" records.")))
+
_
- (let [dummy ($symbol ["" ""])]
- (#Right [state (list (` (_lux_case (~ struct)
- (~ dummy)
- (using (~ dummy)
- (~ body)))))])))
+ (let [dummy (symbol$ ["" ""])]
+ (return (list (` (_lux_case (~ struct)
+ (~ dummy)
+ (using (~ dummy)
+ (~ body))))))))
_
- (#Left "Wrong syntax for defsig")))
+ (fail "Wrong syntax for using")))
(def #export (flip f)
(All [a b c]
@@ -2045,60 +2463,244 @@
(lambda [y x]
(f x y)))
-## (def #export (curry f)
-## (All [a b c]
-## (-> (-> (, a b) c)
-## (-> a b c)))
-## (lambda [x y]
-## (f [x y])))
-
-## (def #export (uncurry f)
-## (All [a b c]
-## (-> (-> a b c)
-## (-> (, a b) c)))
-## (lambda [[x y]]
-## (f x y)))
-
-## (defmacro (loop tokens)
-## (_lux_case tokens
-## (#Cons [bindings (#Cons [body #Nil])])
-## (let [pairs (as-pairs bindings)]
-## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs)))
-## (~ body)))
-## (map second pairs)])))))))
-
-## (defmacro (get@ tokens)
-## (let [output (_lux_case tokens
-## (#Cons [tag (#Cons [record #Nil])])
-## (` (get@' (~ tag) (~ record)))
-
-## (#Cons [tag #Nil])
-## (` (lambda [record] (get@' (~ tag) record))))]
-## (return (list output))))
-
-## (defmacro (set@ tokens)
-## (let [output (_lux_case tokens
-## (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
-## (` (set@' (~ tag) (~ value) (~ record)))
-
-## (#Cons [tag (#Cons [value #Nil])])
-## (` (lambda [record] (set@' (~ tag) (~ value) record)))
-
-## (#Cons [tag #Nil])
-## (` (lambda [value record] (set@' (~ tag) value record))))]
-## (return (list output))))
-
-## (defmacro (update@ tokens)
-## (let [output (_lux_case tokens
-## (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
-## (` (let [_record_ (~ record)]
-## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
-
-## (#Cons [tag (#Cons [func #Nil])])
-## (` (lambda [record]
-## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
-
-## (#Cons [tag #Nil])
-## (` (lambda [func record]
-## (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
-## (return (list output))))
+(def #export (curry f)
+ (All [a b c]
+ (-> (-> (, a b) c)
+ (-> a b c)))
+ (lambda [x y]
+ (f [x y])))
+
+(def #export (uncurry f)
+ (All [a b c]
+ (-> (-> a b c)
+ (-> (, a b) c)))
+ (lambda [xy]
+ (let [[x y] xy]
+ (f x y))))
+
+(defmacro #export (cond tokens)
+ (if (int:= 0 (int:% (length tokens) 2))
+ (fail "cond requires an even number of arguments.")
+ (case (reverse tokens)
+ (\ (list& else branches'))
+ (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [else branch]
+ (let [[right left] branch]
+ (` (if (~ left) (~ right) (~ else))))))
+ else
+ (as-pairs branches'))))
+
+ _
+ (fail "Wrong syntax for cond"))))
+
+(defmacro #export (get@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux:Monad
+ [type (find-var-type name)
+ g!blank (gensym "")
+ g!output (gensym "")]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux:Monad
+ [slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ g!output
+ g!blank)])))
+ slots))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output)))))))
+
+ _
+ (fail "get@ can only use records.")))
+
+ _
+ (do Lux:Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (get@ (~ (tag$ slot')) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for get@")))
+
+(defmacro #export (open tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#SymbolS struct-name)])))
+ (do Lux:Monad
+ [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]))
+ (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name))))))))
+ slots))
+
+ _
+ (fail "Can only \"open\" records.")))
+
+ _
+ (fail "Wrong syntax for open")))
+
+(def (foldL% M f x ys)
+ (All [m a b]
+ (-> (Monad m) (-> a b (m a)) a (List b)
+ (m a)))
+ (case ys
+ (#Cons [y ys'])
+ (do M
+ [x' (f x y)]
+ (foldL% M f x' ys'))
+
+ #Nil
+ ((get@ #return M) x)))
+
+(defmacro #export (:: tokens)
+ (case tokens
+ (\ (list& start parts))
+ (do Lux:Monad
+ [output (foldL% Lux:Monad
+ (: (-> Syntax Syntax (Lux Syntax))
+ (lambda [so-far part]
+ (case part
+ (#Meta [_ (#SymbolS slot)])
+ (return (` (get@ (~ (tag$ slot)) (~ so-far))))
+
+ (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))]))
+ (return (` ((get@ (~ (tag$ slot)) (~ so-far))
+ (~@ args))))
+
+ _
+ (fail "Wrong syntax for ::"))))
+ start parts)]
+ (return (list output)))
+
+ _
+ (fail "Wrong syntax for ::")))
+
+(defmacro #export (set@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) value record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux:Monad
+ [type (find-var-type name)]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux:Monad
+ [pattern' (map% Lux:Monad
+ (: (-> (, Text Type) (Lux (, Text Syntax)))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot]
+ (do Lux:Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name g!slot])))))
+ slots)
+ slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot]
+ [(tag$ (split-slot r-slot-name)) r-var])))
+ pattern'))
+ output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ value
+ r-var)])))
+ pattern'))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "set@ can only use records.")))
+
+ _
+ (do Lux:Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (set@ (~ (tag$ slot')) (~ value) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for set@")))
+
+(defmacro #export (update@ tokens)
+ (case tokens
+ (\ (list (#Meta [_ (#TagS slot')]) fun record))
+ (case record
+ (#Meta [_ (#SymbolS name)])
+ (do Lux:Monad
+ [type (find-var-type name)]
+ (case (resolve-struct-type type)
+ (#Some (#RecordT slots))
+ (do Lux:Monad
+ [pattern' (map% Lux:Monad
+ (: (-> (, Text Type) (Lux (, Text Syntax)))
+ (lambda [slot]
+ (let [[r-slot-name r-type] slot]
+ (do Lux:Monad
+ [g!slot (gensym "")]
+ (return [r-slot-name g!slot])))))
+ slots)
+ slot (normalize slot')]
+ (let [[s-prefix s-name] (: Ident slot)
+ pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot]
+ [(tag$ (split-slot r-slot-name)) r-var])))
+ pattern'))
+ output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[r-slot-name r-var] slot
+ [r-prefix r-name] (split-slot r-slot-name)]
+ [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix)
+ (text:= s-name r-name))
+ (` ((~ fun) (~ r-var)))
+ r-var)])))
+ pattern'))]
+ (return (list (` (_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "update@ can only use records.")))
+
+ _
+ (do Lux:Monad
+ [_record (gensym "")]
+ (return (list (` (let [(~ _record) (~ record)]
+ (update@ (~ (tag$ slot')) (~ fun) (~ _record))))))))
+
+ _
+ (fail "Wrong syntax for update@")))
+
+## (defmacro #export (loop tokens)
+## (case tokens
+## (\ (list bindings body))
+## (let [pairs (as-pairs bindings)
+## vars (map first pairs)
+## inits (map second pairs)]
+## (if (every? symbol? inits)
+## (do Lux:Monad
+## [inits' (map% Maybe:Monad get-ident inits)
+## init-types (map% Maybe:Monad find-var-type inits')]
+## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)]
+## (~ body))
+## (~@ inits))))))
+## (do Lux:Monad
+## [aliases (map% Maybe:Monad (lambda [_] (gensym "")) inits)]
+## (return (list (` (let [(~@ (interleave aliases inits))]
+## (loop [(~@ (interleave vars aliases))]
+## (~ body)))))))))
+
+## _
+## (fail "Wrong syntax for loop")))
diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux
new file mode 100644
index 000000000..1bfd19292
--- /dev/null
+++ b/input/lux/codata/stream.lux
@@ -0,0 +1,63 @@
+## 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.
+
+(;import lux
+ (lux (control (lazy #as L #refer #all))))
+
+## Types
+(deftype #export (Stream a)
+ (Lazy (, a (Stream a))))
+
+## Functions
+(def #export (iterate f x)
+ (All [a]
+ (-> (-> a a) a (Stream a)))
+ (... [x (iterate f (f x))]))
+
+## (def #export (take n xs)
+## (All [a]
+## (-> Int (Stream a) (List a)))
+## (if (int:> n 0)
+## (let [[x xs'] (! xs)]
+## (list& x (take (dec n) xs')))
+## (list)))
+
+## (def #export (drop n xs)
+## (All [a]
+## (-> Int (Stream a) (Stream a)))
+## (if (int:> n 0)
+## (drop (dec n) (get@ 1 (! xs)))
+## xs))
+
+## Pattern-matching
+## (defmacro #export (\stream tokens)
+## (case tokens
+## (\ (list& body patterns'))
+## (do Lux:Monad
+## [patterns (map% Lux:Monad M;macro-expand-1 patterns')
+## g!s (M;gensym "s")
+## #let [patterns+ (do List:Monad
+## [pattern (reverse patterns)]
+## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]]
+## (wrap (list g!s
+## (` (;let [(~@ patterns+)]
+## (~ body))))))
+
+## _
+## "Wrong syntax for \stream"))
+
+## (defsyntax #export (\stream body [patterns' (+$ id$)])
+## (do Lux:Monad
+## [patterns (map% Lux:Monad M;macro-expand-1 patterns')
+## g!s (M;gensym "s")
+## #let [patterns+ (do List:Monad
+## [pattern (reverse patterns)]
+## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]]
+## (wrap (list g!s
+## (` (;let [(~@ patterns+)]
+## (~ body)))))))
diff --git a/input/lux/control/comonad.lux b/input/lux/control/comonad.lux
new file mode 100644
index 000000000..1830ff44f
--- /dev/null
+++ b/input/lux/control/comonad.lux
@@ -0,0 +1,54 @@
+## 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.
+
+(;import lux
+ (../functor #as F)
+ lux/data/list
+ lux/meta/macro)
+
+## Signatures
+(defsig #export (CoMonad w)
+ (: (F;Functor w)
+ _functor)
+ (: (All [a]
+ (-> (w a) a))
+ unwrap)
+ (: (All [a]
+ (-> (w a) (w (w a))))
+ split))
+
+## Functions
+(def #export (extend w f ma)
+ (All [w a b]
+ (-> (CoMonad w) (-> (w a) b) (w a) (w b)))
+ (using w
+ (using ;;_functor
+ (F;map f (;;split ma)))))
+
+## Syntax
+(defmacro #export (be tokens state)
+ (case tokens
+ (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
+ (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body' binding]
+ (let [[var value] binding]
+ (case var
+ (#;Meta [_ (#;TagS ["" "let"])])
+ (` (;let (~ value) (~ body')))
+
+ _
+ (` (extend (;lambda [(~ var)] (~ body'))
+ (~ value)))))))
+ body
+ (reverse (as-pairs bindings)))]
+ (#;Right [state (list (` (;case (~ monad)
+ {#;return ;return #;bind ;bind}
+ (~ body'))))]))
+
+ _
+ (#;Left "Wrong syntax for be")))
diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux
new file mode 100644
index 000000000..3362dd21a
--- /dev/null
+++ b/input/lux/control/functor.lux
@@ -0,0 +1,35 @@
+## 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.
+
+(;import lux
+ (lux/data state))
+
+## Signatures
+(defsig #export (Functor f)
+ (: (All [a b]
+ (-> (-> a b) (f a) (f b)))
+ map))
+
+## Structures
+(defstruct #export Maybe:Functor (Functor Maybe)
+ (def (map f ma)
+ (case ma
+ #;None #;None
+ (#;Some a) (#;Some (f a)))))
+
+(defstruct #export List:Functor (Functor List)
+ (def (map f ma)
+ (case ma
+ #;Nil #;Nil
+ (#;Cons [a ma']) (#;Cons [(f a) (map f ma')]))))
+
+(defstruct #export State:Functor (Functor State)
+ (def (map f ma)
+ (lambda [state]
+ (let [[state' a] (ma state)]
+ [state' (f a)]))))
diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux
new file mode 100644
index 000000000..83f094592
--- /dev/null
+++ b/input/lux/control/lazy.lux
@@ -0,0 +1,47 @@
+## 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.
+
+(;import lux
+ (lux/meta macro)
+ (.. (functor #as F #refer #all)
+ (monad #as M #refer #all))
+ (lux/data list))
+
+## Types
+(deftype #export (Lazy a)
+ (All [b]
+ (-> (-> a b) b)))
+
+## Syntax
+(defmacro #export (... tokens state)
+ (case tokens
+ (\ (list value))
+ (let [blank (symbol$ ["" ""])]
+ (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))]))
+
+ _
+ (#;Left "Wrong syntax for ...")))
+
+## Functions
+(def #export (! thunk)
+ (All [a]
+ (-> (Lazy a) a))
+ (thunk id))
+
+## Structs
+(defstruct #export Lazy:Functor (Functor Lazy)
+ (def (F;map f ma)
+ (... (f (! ma)))))
+
+(defstruct #export Lazy:Monad (Monad Lazy)
+ (def M;_functor Lazy:Functor)
+
+ (def (M;wrap a)
+ (... a))
+
+ (def M;join !))
diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux
new file mode 100644
index 000000000..2ca541574
--- /dev/null
+++ b/input/lux/control/monad.lux
@@ -0,0 +1,107 @@
+## 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.
+
+(;import lux
+ (lux/data list
+ state)
+ (.. (functor #as F)
+ (monoid #as M))
+ lux/meta/macro)
+
+## Signatures
+(defsig #export (Monad m)
+ (: (F;Functor m)
+ _functor)
+ (: (All [a]
+ (-> a (m a)))
+ wrap)
+ (: (All [a]
+ (-> (m (m a)) (m a)))
+ join))
+
+## Syntax
+(defmacro #export (do tokens state)
+ (case tokens
+ (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
+ (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body' binding]
+ (let [[var value] binding]
+ (case var
+ (#;Meta [_ (#;TagS ["" "let"])])
+ (` (;let (~ value) (~ body')))
+
+ _
+ (` (;case ;;_functor
+ {#F;map F;map}
+ (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join))))
+ ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join)))
+ ))))
+ body
+ (reverse (as-pairs bindings)))]
+ (#;Right [state (list (` (;case (~ monad)
+ {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join}
+ (~ body'))))]))
+
+ _
+ (#;Left "Wrong syntax for do")))
+
+## Structures
+(defstruct #export Maybe:Monad (Monad Maybe)
+ (def _functor F;Maybe:Functor)
+
+ (def (wrap x)
+ (#;Some x))
+
+ (def (join mma)
+ (case mma
+ #;None #;None
+ (#;Some xs) xs)))
+
+(defstruct #export List:Monad (Monad List)
+ (def _functor F;List:Functor)
+
+ (def (wrap x)
+ (#;Cons [x #;Nil]))
+
+ (def (join xss)
+ (using M;List:Monoid
+ (foldL M;++ M;unit xss))))
+
+(defstruct #export State:Monad (All [s]
+ (Monad (State s)))
+ (def _functor F;State:Functor)
+
+ (def (wrap x)
+ (lambda [state]
+ [state x]))
+
+ (def (join mma)
+ (lambda [state]
+ (let [[state' ma] (mma state)]
+ (ma state')))))
+
+## Functions
+(def #export (bind m f ma)
+ (All [m a b]
+ (-> (Monad m) (-> a (m b)) (m a) (m b)))
+ (using m
+ (;;join (:: ;;_functor (F;map f ma)))))
+
+(def #export (map% m f xs)
+ (All [m a b]
+ (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
+ (case xs
+ #;Nil
+ (:: m (;;wrap #;Nil))
+
+ (#;Cons [x xs'])
+ (do m
+ [y (f x)
+ ys (map% m f xs')]
+ (;;wrap (#;Cons [y ys])))
+ ))
diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux
new file mode 100644
index 000000000..cfb282c52
--- /dev/null
+++ b/input/lux/control/monoid.lux
@@ -0,0 +1,57 @@
+## 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.
+
+(;import lux
+ (lux/data ord
+ (bounded #as B)))
+
+## Signatures
+(defsig #export (Monoid a)
+ (: a
+ unit)
+ (: (-> a a a)
+ ++))
+
+## Constructors
+(def #export (monoid$ unit ++)
+ (All [a]
+ (-> a (-> a a a) (Monoid a)))
+ (struct
+ (def unit unit)
+ (def ++ ++)))
+
+## Structures
+(defstruct #export Maybe:Monoid (Monoid Maybe)
+ (def unit #;None)
+ (def (++ xs ys)
+ (case xs
+ #;None ys
+ (#;Some x) (#;Some x))))
+
+(defstruct #export List:Monoid (All [a]
+ (Monoid (List a)))
+ (def unit #;Nil)
+ (def (++ xs ys)
+ (case xs
+ #;Nil ys
+ (#;Cons [x xs']) (#;Cons [x (++ xs' ys)]))))
+
+(do-template [<name> <type> <unit> <++>]
+ [(defstruct #export <name> (Monoid <type>)
+ (def unit <unit>)
+ (def ++ <++>))]
+
+ [ IntAdd:Monoid Int 0 int:+]
+ [ IntMul:Monoid Int 1 int:*]
+ [RealAdd:Monoid Real 0.0 real:+]
+ [RealMul:Monoid Real 1.0 real:*]
+ [ IntMax:Monoid Int (:: B;Int:Bounded B;bottom) (max Int:Ord)]
+ [ IntMin:Monoid Int (:: B;Int:Bounded B;top) (min Int:Ord)]
+ [RealMax:Monoid Real (:: B;Real:Bounded B;bottom) (max Real:Ord)]
+ [RealMin:Monoid Real (:: B;Real:Bounded B;top) (min Real:Ord)]
+ )
diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux
new file mode 100644
index 000000000..14f4d2e86
--- /dev/null
+++ b/input/lux/data/bounded.lux
@@ -0,0 +1,26 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Bounded a)
+ (: a
+ top)
+
+ (: a
+ bottom))
+
+## Structure
+(do-template [<name> <type> <top> <bottom>]
+ [(defstruct #export <name> (Bounded <type>)
+ (def top <top>)
+ (def bottom <bottom>))]
+
+ [Int:Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)]
+ [Real:Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)])
diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux
new file mode 100644
index 000000000..8bd6635fd
--- /dev/null
+++ b/input/lux/data/dict.lux
@@ -0,0 +1,83 @@
+## 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.
+
+(;import lux
+ (lux/data (eq #as E)))
+
+## Signatures
+(defsig #export (Dict d)
+ (: (All [k v]
+ (-> k (d k v) (Maybe v)))
+ get)
+ (: (All [k v]
+ (-> k v (d k v) (d k v)))
+ put)
+ (: (All [k v]
+ (-> k (d k v) (d k v)))
+ remove))
+
+## Types
+(deftype #export (PList k v)
+ (| (#PList (, (E;Eq k) (List (, k v))))))
+
+## Constructors
+(def #export (plist eq)
+ (All [k v]
+ (-> (E;Eq k) (PList k v)))
+ (#PList [eq #;Nil]))
+
+## Utils
+(def (pl-get eq k kvs)
+ (All [k v]
+ (-> (E;Eq k) k (List (, k v)) (Maybe v)))
+ (case kvs
+ #;Nil
+ #;None
+
+ (#;Cons [[k' v'] kvs'])
+ (if (:: eq (E;= k k'))
+ (#;Some v')
+ (pl-get eq k kvs'))))
+
+(def (pl-put eq k v kvs)
+ (All [k v]
+ (-> (E;Eq k) k v (List (, k v)) (List (, k v))))
+ (case kvs
+ #;Nil
+ (#;Cons [[k v] kvs])
+
+ (#;Cons [[k' v'] kvs'])
+ (if (:: eq (E;= k k'))
+ (#;Cons [[k v] kvs'])
+ (#;Cons [[k' v'] (pl-put eq k v kvs')]))))
+
+(def (pl-remove eq k kvs)
+ (All [k v]
+ (-> (E;Eq k) k (List (, k v)) (List (, k v))))
+ (case kvs
+ #;Nil
+ kvs
+
+ (#;Cons [[k' v'] kvs'])
+ (if (:: eq (E;= k k'))
+ kvs'
+ (#;Cons [[k' v'] (pl-remove eq k kvs')]))))
+
+## Structs
+(defstruct #export PList:Dict (Dict PList)
+ (def (get k plist)
+ (let [(#PList [eq kvs]) plist]
+ (pl-get eq k kvs)))
+
+ (def (put k v plist)
+ (let [(#PList [eq kvs]) plist]
+ (#PList [eq (pl-put eq k v kvs)])))
+
+ (def (remove k plist)
+ (let [(#PList [eq kvs]) plist]
+ (#PList [eq (pl-remove eq k kvs)]))))
diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux
new file mode 100644
index 000000000..948f8e2ab
--- /dev/null
+++ b/input/lux/data/eq.lux
@@ -0,0 +1,35 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Eq a)
+ (: (-> a a Bool)
+ =))
+
+## Structures
+(defstruct #export Bool:Eq (Eq Bool)
+ (def (= x y)
+ (case (: (, Bool Bool) [x y])
+ (\or [true true] [false false])
+ true
+
+ _
+ false)))
+
+(defstruct #export Int:Eq (Eq Int)
+ (def = int:=))
+
+(defstruct #export Real:Eq (Eq Real)
+ (def = real:=))
+
+(defstruct #export Text:Eq (Eq Text)
+ (def (= x y)
+ (_jvm_invokevirtual java.lang.Object equals [java.lang.Object]
+ x [y])))
diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux
new file mode 100644
index 000000000..ab74daefd
--- /dev/null
+++ b/input/lux/data/io.lux
@@ -0,0 +1,51 @@
+## 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.
+
+(;import lux
+ (lux/meta macro)
+ (lux/control (functor #as F)
+ (monad #as M))
+ lux/data/list)
+
+## Types
+(deftype #export (IO a)
+ (-> (,) a))
+
+## Syntax
+(defmacro #export (io tokens state)
+ (case tokens
+ (\ (list value))
+ (let [blank (symbol$ ["" ""])]
+ (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))]))
+
+ _
+ (#;Left "Wrong syntax for io")))
+
+## Structures
+(defstruct #export IO:Functor (F;Functor IO)
+ (def (F;map f ma)
+ (io (f (ma [])))))
+
+(defstruct #export IO:Monad (M;Monad IO)
+ (def M;_functor IO:Functor)
+
+ (def (M;wrap x)
+ (io x))
+
+ (def (M;join mma)
+ (mma [])))
+
+## Functions
+(def #export (print x)
+ (-> Text (IO (,)))
+ (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object]
+ (_jvm_getstatic java.lang.System out) [x])))
+
+(def #export (println x)
+ (-> Text (IO (,)))
+ (print (text:++ x "\n")))
diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux
new file mode 100644
index 000000000..edbdb6160
--- /dev/null
+++ b/input/lux/data/list.lux
@@ -0,0 +1,218 @@
+## 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.
+
+(;import (lux #refer (#except reverse as-pairs))
+ lux/meta/macro)
+
+## Types
+## (deftype (List a)
+## (| #Nil
+## (#Cons (, a (List a)))))
+
+## Functions
+(def #export (foldL f init xs)
+ (All [a b]
+ (-> (-> a b a) a (List b) a))
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (foldL f (f init x) xs')))
+
+(def #export (foldR f init xs)
+ (All [a b]
+ (-> (-> b a a) a (List b) a))
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (f x (foldR f init xs'))))
+
+(def #export (reverse xs)
+ (All [a]
+ (-> (List a) (List a)))
+ (foldL (lambda [tail head] (#;Cons [head tail]))
+ #;Nil
+ xs))
+
+(def #export (filter p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (#;Cons [x (filter p xs')])
+ (filter p xs'))))
+
+(def #export (as-pairs xs)
+ (All [a] (-> (List a) (List (, a a))))
+ (case xs
+ (\ (#;Cons [x1 (#;Cons [x2 xs'])]))
+ (#;Cons [[x1 x2] (as-pairs xs')])
+
+ _
+ #;Nil))
+
+(do-template [<name> <then> <else>]
+ [(def #export (<name> n xs)
+ (All [a]
+ (-> Int (List a) (List a)))
+ (if (int:> n 0)
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ <then>)
+ <else>))]
+
+ [take (#;Cons [x (take (dec n) xs')]) #;Nil]
+ [drop (drop (dec n) xs') xs]
+ )
+
+(do-template [<name> <then> <else>]
+ [(def #export (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ (if (p x)
+ <then>
+ <else>)))]
+
+ [take-while (#;Cons [x (take-while p xs')]) #;Nil]
+ [drop-while (drop-while p xs') xs]
+ )
+
+(def #export (split-at n xs)
+ (All [a]
+ (-> Int (List a) (, (List a) (List a))))
+ (if (int:> n 0)
+ (case xs
+ #;Nil
+ [#;Nil #;Nil]
+
+ (#;Cons [x xs'])
+ (let [[tail rest] (split-at (dec n) xs')]
+ [(#;Cons [x tail]) rest]))
+ [#;Nil xs]))
+
+(def (split-with' p ys xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a) (, (List a) (List a))))
+ (case xs
+ #;Nil
+ [ys xs]
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (split-with' p (#;Cons [x ys]) xs')
+ [ys xs])))
+
+(def #export (split-with p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (, (List a) (List a))))
+ (let [[ys' xs'] (split-with' p #;Nil xs)]
+ [(reverse ys') xs']))
+
+(def #export (repeat n x)
+ (All [a]
+ (-> Int a (List a)))
+ (if (int:> n 0)
+ (#;Cons [x (repeat (dec n) x)])
+ #;Nil))
+
+(def #export (iterate f x)
+ (All [a]
+ (-> (-> a (Maybe a)) a (List a)))
+ (case (f x)
+ (#;Some x')
+ (#;Cons [x (iterate f x')])
+
+ #;None
+ (#;Cons [x #;Nil])))
+
+(def #export (some f xs)
+ (All [a b]
+ (-> (-> a (Maybe b)) (List a) (Maybe b)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons [x xs'])
+ (case (f x)
+ #;None
+ (some f xs')
+
+ (#;Some y)
+ (#;Some y))))
+
+(def #export (interpose sep xs)
+ (All [a]
+ (-> a (List a) (List a)))
+ (case xs
+ #;Nil
+ xs
+
+ (#;Cons [x #;Nil])
+ xs
+
+ (#;Cons [x xs'])
+ (#;Cons [x (#;Cons [sep (interpose sep xs')])])))
+
+(def #export (size list)
+ (-> List Int)
+ (foldL (lambda [acc _] (int:+ 1 acc)) 0 list))
+
+(do-template [<name> <init> <op>]
+ [(def #export (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) Bool))
+ (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))]
+
+ [every? true and]
+ [any? false or])
+
+(def #export (@ i xs)
+ (All [a]
+ (-> Int (List a) (Maybe a)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons [x xs'])
+ (if (int:= 0 i)
+ (#;Some x)
+ (@ (dec i) xs'))))
+
+## Syntax
+(defmacro #export (list xs state)
+ (#;Right [state (#;Cons [(foldL (lambda [tail head]
+ (` (#;Cons [(~ head) (~ tail)])))
+ (` #;Nil)
+ (reverse xs))
+ #;Nil])]))
+
+(defmacro #export (list& xs state)
+ (case (reverse xs)
+ (#;Cons [last init])
+ (#;Right [state (list (foldL (lambda [tail head]
+ (` (#;Cons [(~ head) (~ tail)])))
+ last
+ init))])
+
+ _
+ (#;Left "Wrong syntax for list&")))
diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux
new file mode 100644
index 000000000..7941daa4e
--- /dev/null
+++ b/input/lux/data/number.lux
@@ -0,0 +1,64 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Number n)
+ (: (-> n n n)
+ +)
+
+ (: (-> n n n)
+ -)
+
+ (: (-> n n n)
+ *)
+
+ (: (-> n n n)
+ /)
+
+ (: (-> n n n)
+ %)
+
+ (: (-> Int n)
+ from-int)
+
+ (: (-> n n)
+ negate)
+
+ (: (-> n n)
+ sign)
+
+ (: (-> n n)
+ abs))
+
+## Structures
+(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>]
+ [(defstruct #export <name> (Number <type>)
+ (def + <+>)
+ (def - <->)
+ (def * <*>)
+ (def / </>)
+ (def % <%>)
+ (def (from-int x)
+ (<from> x))
+ (def (negate x)
+ (<*> <-1> x))
+ (def (abs x)
+ (if (<<> x <0>)
+ (<*> <-1> x)
+ x))
+ (def (sign x)
+ (cond (<=> x <0>) <0>
+ (<<> x <0>) <-1>
+ ## else
+ <1>))
+ )]
+
+ [Int:Number Int int:+ int:- int:* int:/ int:% int:= int:< id 0 1 -1]
+ [Real:Number Real real:+ real:- real:* real:/ real:% real:= real:< _jvm_l2d 0.0 1.0 -1.0])
diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux
new file mode 100644
index 000000000..573106830
--- /dev/null
+++ b/input/lux/data/ord.lux
@@ -0,0 +1,56 @@
+## 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.
+
+(;import lux
+ (../eq #as E))
+
+## Signatures
+(defsig #export (Ord a)
+ (: (E;Eq a)
+ _eq)
+ (: (-> a a Bool)
+ <)
+ (: (-> a a Bool)
+ <=)
+ (: (-> a a Bool)
+ >)
+ (: (-> a a Bool)
+ >=))
+
+## Constructors
+(def #export (ord$ eq < >)
+ (All [a]
+ (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a)))
+ (struct
+ (def _eq eq)
+ (def < <)
+ (def (<= x y)
+ (or (< x y)
+ (:: eq (E;= x y))))
+ (def > >)
+ (def (>= x y)
+ (or (> x y)
+ (:: eq (E;= x y))))))
+
+## Functions
+(do-template [<name> <op>]
+ [(def #export (<name> ord x y)
+ (All [a]
+ (-> (Ord a) a a a))
+ (using ord
+ (if (<op> x y) x y)))]
+
+ [max ;;>]
+ [min ;;<])
+
+## Structures
+(def #export Int:Ord (Ord Int)
+ (ord$ E;Int:Eq int:< int:>))
+
+(def #export Real:Ord (Ord Real)
+ (ord$ E;Real:Eq real:< real:>))
diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux
new file mode 100644
index 000000000..3748d481a
--- /dev/null
+++ b/input/lux/data/show.lux
@@ -0,0 +1,27 @@
+## 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.
+
+(;import lux)
+
+## Signatures
+(defsig #export (Show a)
+ (: (-> a Text)
+ show))
+
+## Structures
+(do-template [<name> <type> <body>]
+ [(defstruct #export <name> (Show <type>)
+ (def (show x)
+ <body>))]
+
+ [Bool:Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])]
+ [Int:Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])]
+ [Real:Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])]
+ [Char:Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])]
+ ($ text:++ "#\"" char "\""))]
+ [Text:Show Text x])
diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux
new file mode 100644
index 000000000..386c7be1d
--- /dev/null
+++ b/input/lux/data/state.lux
@@ -0,0 +1,13 @@
+## 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.
+
+(;import lux)
+
+## Types
+(deftype #export (State s a)
+ (-> s (, s a)))
diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux
new file mode 100644
index 000000000..1a8587f46
--- /dev/null
+++ b/input/lux/data/text.lux
@@ -0,0 +1,139 @@
+## 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.
+
+(;import lux
+ (lux/data (eq #as E)
+ (ord #as O)))
+
+## [Functions]
+(def #export (size x)
+ (-> Text Int)
+ (_jvm_i2l (_jvm_invokevirtual java.lang.String length []
+ x [])))
+
+(def #export (@ idx x)
+ (-> Int Text (Maybe Char))
+ (if (and (int:< idx (size x))
+ (int:>= idx 0))
+ (#;Some (_jvm_invokevirtual java.lang.String charAt [int]
+ x [(_jvm_l2i idx)]))
+ #;None))
+
+(def #export (++ x y)
+ (-> Text Text Text)
+ (_jvm_invokevirtual java.lang.String concat [java.lang.String]
+ x [y]))
+
+(def #export (contains? x y)
+ (-> Text Text Bool)
+ (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence]
+ x [y]))
+
+(do-template [<name> <method>]
+ [(def #export (<name> x)
+ (-> Text Text)
+ (_jvm_invokevirtual java.lang.String <method> []
+ x []))]
+ [lower-case toLowerCase]
+ [upper-case toUpperCase]
+ [trim trim]
+ )
+
+(def #export (sub' from to x)
+ (-> Int Int Text (Maybe Text))
+ (if (and (int:< from to)
+ (int:>= from 0)
+ (int:<= to (size x)))
+ (_jvm_invokevirtual java.lang.String substring [int int]
+ x [(_jvm_l2i from) (_jvm_l2i to)])
+ #;None))
+
+(def #export (sub from x)
+ (-> Int Text (Maybe Text))
+ (sub' from (size x) x))
+
+(def #export (split at x)
+ (-> Int Text (Maybe (, Text Text)))
+ (if (and (int:< at (size x))
+ (int:>= at 0))
+ (let [pre (_jvm_invokevirtual java.lang.String substring [int int]
+ x [(_jvm_l2i 0) (_jvm_l2i at)])
+ post (_jvm_invokevirtual java.lang.String substring [int]
+ x [(_jvm_l2i at)])]
+ (#;Some [pre post]))
+ #;None))
+
+(def #export (replace pattern value template)
+ (-> Text Text Text Text)
+ (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence]
+ template [pattern value]))
+
+(do-template [<common> <general> <method>]
+ [(def #export (<general> pattern from x)
+ (-> Text Int Text (Maybe Int))
+ (if (and (int:< from (size x))
+ (int:>= from 0))
+ (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String int]
+ x [pattern (_jvm_l2i from)]))
+ -1 #;None
+ idx (#;Some idx))
+ #;None))
+
+ (def #export (<common> pattern x)
+ (-> Text Text (Maybe Int))
+ (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String]
+ x [pattern]))
+ -1 #;None
+ idx (#;Some idx)))]
+
+ [index-of index-of' indexOf]
+ [last-index-of last-index-of' lastIndexOf]
+ )
+
+(def #export (starts-with? prefix x)
+ (-> Text Text Bool)
+ (case (index-of prefix x)
+ (#;Some 0)
+ true
+
+ _
+ false))
+
+(def #export (ends-with? postfix x)
+ (-> Text Text Bool)
+ (case (last-index-of postfix x)
+ (#;Some n)
+ (int:= (int:+ n (size postfix))
+ (size x))
+
+ _
+ false))
+
+(defstruct #export Text:Eq (E;Eq Text)
+ (def (E;= x y)
+ (_jvm_invokevirtual java.lang.Object equals [java.lang.Object]
+ x [y])))
+
+(defstruct #export Text:Ord (O;Ord Text)
+ (def O;_eq Text:Eq)
+ (def (O;< x y)
+ (int:< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0))
+ (def (O;<= x y)
+ (int:<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0))
+ (def (O;> x y)
+ (int:> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0))
+ (def (O;>= x y)
+ (int:>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String]
+ x [y]))
+ 0)))
diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux
new file mode 100644
index 000000000..bd4fab8b6
--- /dev/null
+++ b/input/lux/meta/lux.lux
@@ -0,0 +1,185 @@
+## 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.
+
+(;import lux
+ (.. macro)
+ (lux/control (monoid #as m #refer (#only List:Monoid))
+ (functor #as F)
+ (monad #as M #refer (#only do)))
+ (lux/data list
+ (show #as S)))
+
+## Types
+## (deftype (Lux a)
+## (-> Compiler (Either Text (, Compiler a))))
+
+## Structures
+(defstruct #export Lux:Functor (F;Functor Lux)
+ (def (F;map f fa)
+ (lambda [state]
+ (case (fa state)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [state' a])
+ (#;Right [state' (f a)])))))
+
+(defstruct #export Lux:Monad (M;Monad Lux)
+ (def M;_functor Lux:Functor)
+ (def (M;wrap x)
+ (lambda [state]
+ (#;Right [state x])))
+ (def (M;join mma)
+ (lambda [state]
+ (case (mma state)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [state' ma])
+ (ma state')))))
+
+## Functions
+(def #export (get-module-name state)
+ (Lux Text)
+ (case (reverse (get@ #;envs state))
+ #;Nil
+ (#;Left "Can't get the module name without a module!")
+
+ (#;Cons [env _])
+ (#;Right [state (get@ #;name env)])))
+
+(def (get k plist)
+ (All [a]
+ (-> Text (List (, Text a)) (Maybe a)))
+ (case plist
+ #;Nil
+ #;None
+
+ (#;Cons [[k' v] plist'])
+ (if (text:= k k')
+ (#;Some v)
+ (get k plist'))))
+
+(def (find-macro' modules current-module module name)
+ (-> (List (, Text (Module Compiler))) Text Text Text
+ (Maybe Macro))
+ (do M;Maybe:Monad
+ [$module (get module modules)
+ gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))]
+ (case (: (, Bool (DefData' Macro)) gdef)
+ [exported? (#;MacroD macro')]
+ (if (or exported? (text:= module current-module))
+ (#;Some macro')
+ #;None)
+
+ [_ (#;AliasD [r-module r-name])]
+ (find-macro' modules current-module r-module r-name)
+
+ _
+ #;None)))
+
+(def #export (find-macro ident)
+ (-> Ident (Lux (Maybe Macro)))
+ (do Lux:Monad
+ [current-module get-module-name]
+ (let [[module name] ident]
+ (: (Lux (Maybe Macro))
+ (lambda [state]
+ (#;Right [state (find-macro' (get@ #;modules state) current-module module name)]))))))
+
+(def #export (normalize ident)
+ (-> Ident (Lux Ident))
+ (case ident
+ ["" name]
+ (do Lux:Monad
+ [module-name get-module-name]
+ (M;wrap (: Ident [module-name name])))
+
+ _
+ (:: Lux:Monad (M;wrap ident))))
+
+(def #export (macro-expand syntax)
+ (-> Syntax (Lux (List Syntax)))
+ (case syntax
+ (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))])
+ (do Lux:Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (case ?macro
+ (#;Some macro)
+ (do Lux:Monad
+ [expansion (macro args)
+ expansion' (M;map% Lux:Monad macro-expand expansion)]
+ (M;wrap (:: M;List:Monad (M;join expansion'))))
+
+ #;None
+ (do Lux:Monad
+ [parts' (M;map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))]
+ (M;wrap (list (form$ (:: M;List:Monad (M;join parts'))))))))
+
+ (#;Meta [_ (#;FormS (#;Cons [harg targs]))])
+ (do Lux:Monad
+ [harg+ (macro-expand harg)
+ targs+ (M;map% Lux:Monad macro-expand targs)]
+ (M;wrap (list (form$ (list:++ harg+ (:: M;List:Monad (M;join (: (List (List Syntax)) targs+))))))))
+
+ (#;Meta [_ (#;TupleS members)])
+ (do Lux:Monad
+ [members' (M;map% Lux:Monad macro-expand members)]
+ (M;wrap (list (tuple$ (:: M;List:Monad (M;join members'))))))
+
+ _
+ (:: Lux:Monad (M;wrap (list syntax)))))
+
+(def #export (gensym prefix state)
+ (-> Text (Lux Syntax))
+ (#;Right [(update@ #;seed inc state)
+ (symbol$ ["__gensym__" (:: S;Int:Show (S;show (get@ #;seed state)))])]))
+
+(def #export (fail msg)
+ (All [a]
+ (-> Text (Lux a)))
+ (lambda [_]
+ (#;Left msg)))
+
+(def #export (macro-expand-1 token)
+ (-> Syntax (Lux Syntax))
+ (do Lux:Monad
+ [token+ (macro-expand token)]
+ (case token+
+ (\ (list token'))
+ (M;wrap token')
+
+ _
+ (fail "Macro expanded to more than 1 element."))))
+
+(def #export (module-exists? module state)
+ (-> Text (Lux Bool))
+ (#;Right [state (case (get module (get@ #;modules state))
+ (#;Some _)
+ true
+
+ #;None
+ false)]))
+
+(def #export (exported-defs module state)
+ (-> Text (Lux (List Text)))
+ (case (get module (get@ #;modules state))
+ (#;Some =module)
+ (using M;List:Monad
+ (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro)))
+ (List Text))
+ (lambda [gdef]
+ (let [[name [export? _]] gdef]
+ (if export?
+ (list name)
+ (list)))))
+ (get@ #;defs =module))))]))
+
+ #;None
+ (#;Left ($ text:++ "Unknown module: " module))))
diff --git a/input/lux/meta/macro.lux b/input/lux/meta/macro.lux
new file mode 100644
index 000000000..22aeaf874
--- /dev/null
+++ b/input/lux/meta/macro.lux
@@ -0,0 +1,54 @@
+## 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.
+
+(;import lux)
+
+## [Utils]
+(def (_meta x)
+ (-> (Syntax' (Meta Cursor)) Syntax)
+ (#;Meta [["" -1 -1] x]))
+
+## [Syntax]
+(def #export (defmacro tokens state)
+ Macro
+ (case tokens
+ (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])
+ (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args))
+ (~ (_meta (#;SymbolS ["lux" "Macro"])))
+ (~ body)))
+ (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
+ #;Nil])])])
+
+ (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])])
+ (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args))
+ (~ (_meta (#;SymbolS ["lux" "Macro"])))
+ (~ body)))
+ (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name)))
+ #;Nil])])])
+
+ _
+ (#;Left "Wrong syntax for defmacro")))
+(_lux_declare-macro defmacro)
+
+## [Functions]
+(do-template [<name> <type> <tag>]
+ [(def #export (<name> x)
+ (-> <type> Syntax)
+ (#;Meta [["" -1 -1] (<tag> x)]))]
+
+ [bool$ Bool #;BoolS]
+ [int$ Int #;IntS]
+ [real$ Real #;RealS]
+ [char$ Char #;CharS]
+ [text$ Text #;TextS]
+ [symbol$ Ident #;SymbolS]
+ [tag$ Ident #;TagS]
+ [form$ (List Syntax) #;FormS]
+ [tuple$ (List Syntax) #;TupleS]
+ [record$ (List (, Syntax Syntax)) #;RecordS]
+ )
diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux
new file mode 100644
index 000000000..cf08ff0eb
--- /dev/null
+++ b/input/lux/meta/syntax.lux
@@ -0,0 +1,237 @@
+## 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.
+
+(;import lux
+ (.. (macro #as m #refer #all)
+ lux)
+ (lux (control (functor #as F)
+ (monad #as M #refer (#only do)))
+ (data list)))
+
+## [Utils]
+(def (first xy)
+ (All [a b] (-> (, a b) a))
+ (let [[x y] xy]
+ x))
+
+## Types
+(deftype #export (Parser a)
+ (-> (List Syntax) (Maybe (, (List Syntax) a))))
+
+## Structures
+(defstruct #export Parser:Functor (F;Functor Parser)
+ (def (F;map f ma)
+ (lambda [tokens]
+ (case (ma tokens)
+ #;None
+ #;None
+
+ (#;Some [tokens' a])
+ (#;Some [tokens' (f a)])))))
+
+(defstruct #export Parser:Monad (M;Monad Parser)
+ (def M;_functor Parser:Functor)
+
+ (def (M;wrap x tokens)
+ (#;Some [tokens x]))
+
+ (def (M;join mma)
+ (lambda [tokens]
+ (case (mma tokens)
+ #;None
+ #;None
+
+ (#;Some [tokens' ma])
+ (ma tokens')))))
+
+## Parsers
+(def #export (id^ tokens)
+ (Parser Syntax)
+ (case tokens
+ #;Nil #;None
+ (#;Cons [t tokens']) (#;Some [tokens' t])))
+
+(do-template [<name> <type> <tag>]
+ [(def #export (<name> tokens)
+ (Parser <type>)
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
+ (#;Some [tokens' x])
+
+ _
+ #;None))]
+
+ [ bool^ Bool #;BoolS]
+ [ int^ Int #;IntS]
+ [ real^ Real #;RealS]
+ [ char^ Char #;CharS]
+ [ text^ Text #;TextS]
+ [symbol^ Ident #;SymbolS]
+ [ tag^ Ident #;TagS]
+ )
+
+(def (bool:= x y)
+ (-> Bool Bool Bool)
+ (if x
+ y
+ (not y)))
+
+(def (ident:= x y)
+ (-> Ident Ident Bool)
+ (let [[x1 x2] x
+ [y1 y2] y]
+ (and (text:= x1 y1)
+ (text:= x2 y2))))
+
+(do-template [<name> <type> <tag> <eq>]
+ [(def #export (<name> v tokens)
+ (-> <type> (Parser (,)))
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
+ (if (<eq> v x)
+ (#;Some [tokens' []])
+ #;None)
+
+ _
+ #;None))]
+
+ [ bool?^ Bool #;BoolS bool:=]
+ [ int?^ Int #;IntS int:=]
+ [ real?^ Real #;RealS real:=]
+ ## [ char?^ Char #;CharS char:=]
+ [ text?^ Text #;TextS text:=]
+ [symbol?^ Ident #;SymbolS ident:=]
+ [ tag?^ Ident #;TagS ident:=]
+ )
+
+(do-template [<name> <tag>]
+ [(def #export (<name> p tokens)
+ (All [a]
+ (-> (Parser a) (Parser a)))
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> form)]) tokens'])
+ (case (p form)
+ (#;Some [#;Nil x]) (#;Some [tokens' x])
+ _ #;None)
+
+ _
+ #;None))]
+
+ [ form^ #;FormS]
+ [tuple^ #;TupleS]
+ )
+
+(def #export (?^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser (Maybe a))))
+ (case (p tokens)
+ #;None (#;Some [tokens #;None])
+ (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])))
+
+(def (run-parser p tokens)
+ (All [a]
+ (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a))))
+ (p tokens))
+
+(def #export (*^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser (List a))))
+ (case (p tokens)
+ #;None (#;Some [tokens (list)])
+ (#;Some [tokens' x]) (run-parser (do Parser:Monad
+ [xs (*^ p)]
+ (M;wrap (list& x xs)))
+ tokens')))
+
+(def #export (+^ p)
+ (All [a]
+ (-> (Parser a) (Parser (List a))))
+ (do Parser:Monad
+ [x p
+ xs (*^ p)]
+ (M;wrap (list& x xs))))
+
+(def #export (&^ p1 p2)
+ (All [a b]
+ (-> (Parser a) (Parser b) (Parser (, a b))))
+ (do Parser:Monad
+ [x1 p1
+ x2 p2]
+ (M;wrap [x1 x2])))
+
+(def #export (|^ p1 p2 tokens)
+ (All [a b]
+ (-> (Parser a) (Parser b) (Parser (Either b))))
+ (case (p1 tokens)
+ (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)])
+ #;None (run-parser (do Parser:Monad
+ [x2 p2]
+ (M;wrap (#;Right x2)))
+ tokens)))
+
+(def #export (||^ ps tokens)
+ (All [a]
+ (-> (List (Parser a)) (Parser (Maybe a))))
+ (case ps
+ #;Nil #;None
+ (#;Cons [p ps']) (case (p tokens)
+ #;None (||^ ps' tokens)
+ (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))
+ ))
+
+(def #export (end^ tokens)
+ (Parser (,))
+ (case tokens
+ #;Nil (#;Some [tokens []])
+ _ #;None))
+
+## Syntax
+(defmacro #export (defsyntax tokens)
+ (case tokens
+ (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))])
+ body))
+ (do Lux:Monad
+ [names+parsers (M;map% Lux:Monad
+ (: (-> Syntax (Lux (, Syntax Syntax)))
+ (lambda [arg]
+ (case arg
+ (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)])
+ parser))]))
+ (M;wrap [(symbol$ var-name) parser])
+
+ _
+ (fail "Syntax pattern expects 2-tuples."))))
+ args)
+ g!tokens (gensym "tokens")
+ #let [names (:: F;List:Functor (F;map first names+parsers))
+ error-msg (text$ (text:++ "Wrong syntax for " name))
+ parsing (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body name+parser]
+ (let [[name parser] name+parser]
+ (` (_lux_case ((~ parser) (~ g!tokens))
+ (#;Some [(~ g!tokens) (~ name)])
+ (~ body)
+
+ _
+ #;None)))))
+ (: Syntax (` (#;Some [(~@ names)])))
+ (reverse names+parsers))
+ body' (: Syntax
+ (` (_lux_case (~ parsing)
+ (#;Some [#;Nil [(~@ names)]])
+ (~ body)
+
+ _
+ (l;fail (~ (text$ (text:++ "Wrong syntax for " name)))))))
+ macro-def (: Syntax
+ (` (m/defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
+ (~ body'))))]]
+ (M;wrap (list macro-def)))
+
+ _
+ (fail "Wrong syntax for defsyntax")))
diff --git a/input/program.lux b/input/program.lux
index 4f329c3fa..6495854c1 100644
--- a/input/program.lux
+++ b/input/program.lux
@@ -1,15 +1,28 @@
-(;lux)
-
-(def (filter p xs)
- (All [a] (-> (-> a Bool) (List a) (List a)))
- (case xs
- #;Nil
- (list)
-
- (#;Cons [x xs'])
- (if (p x)
- (list& x (filter p xs'))
- (filter p xs'))))
+(;import lux
+ (lux (control monoid
+ functor
+ monad
+ lazy
+ comonad)
+ (data eq
+ bounded
+ ord
+ io
+ list
+ state
+ number
+ (text #as t)
+ dict
+ show)
+ (codata (stream #refer (#except iterate)))
+ (meta lux
+ macro
+ syntax)))
(_jvm_program args
- (println "Hello, world!"))
+ (case args
+ #;Nil
+ (println "Hello, world!")
+
+ (#;Cons [name _])
+ (println ($ text:++ "Hello, " name "!"))))
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 039db810a..8c8be29d2 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -115,6 +115,12 @@
["lux;Nil" _]]]]]]]
(&&lux/analyse-export analyse ?ident)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]]
+ ["lux;Nil" _]]]]]]]]]
+ (&&lux/analyse-alias analyse ?alias ?module)
+
[_]
(fail "")))
@@ -447,7 +453,7 @@
;; Programs
[["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]]
["lux;Cons" [?body
["lux;Nil" _]]]]]]]]]
(&&host/analyse-jvm-program analyse ?args ?body)
@@ -500,6 +506,9 @@
[["lux;Right" [state* output]]]
(return* state* output)
+ [["lux;Left" ""]]
+ (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token))))
+
[["lux;Left" msg]]
(fail* (add-loc meta msg)))
@@ -522,6 +531,21 @@
(fail* (add-loc meta msg))
))))
+(defn ^:private just-analyse [analyse-ast eval! compile-module syntax]
+ (&type/with-var
+ (fn [?var]
+ (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)]
+ (matchv ::M/objects [?var ?output-type]
+ [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]]
+ (if (= ?e-id ?a-id)
+ (|do [?output-type* (&type/deref ?e-id)]
+ (return (&/T ?output-term ?output-type*)))
+ (return (&/T ?output-term ?output-type)))
+
+ [_ _]
+ (return (&/T ?output-term ?output-type)))
+ ))))
+
(defn ^:private analyse-ast [eval! compile-module exo-type token]
(matchv ::M/objects [token]
[["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]]
@@ -530,10 +554,12 @@
[["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]]
(fn [state]
- (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)]
+ (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state)
+ ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)
+ ]
[["lux;Right" [state* =fn]]]
(do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0))
- ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*))
+ ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*))
[_]
((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state)))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 43e5ee5e7..6efe7fd5f 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -15,6 +15,15 @@
(fail "##9##")))]
(resolve-type type*))
+ [["lux;AllT" ?id]]
+ (|do [$var &type/existential
+ =type (&type/apply-type type $var)]
+ (&type/actual-type =type))
+ ;; (&type/with-var
+ ;; (fn [$var]
+ ;; (|do [=type (&type/apply-type type $var)]
+ ;; (&type/actual-type =type))))
+
[_]
(&type/actual-type type)))
@@ -68,7 +77,7 @@
(return (&/T (&/V "TupleTestAC" =tests) =kont))))
[_]
- (fail "[Analyser Error] Tuple requires tuple-type."))
+ (fail "[Analyser Error] Tuples require tuple-type."))
[["lux;RecordS" ?slots]]
(|do [value-type* (resolve-type value-type)]
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
index fa7b9aa1a..de6bdb036 100644
--- a/src/lux/analyser/env.clj
+++ b/src/lux/analyser/env.clj
@@ -16,18 +16,20 @@
=return (body (&/update$ &/$ENVS
(fn [stack]
(let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))]
- (&/|cons (->> (&/|head stack)
- (&/update$ &/$LOCALS #(&/update$ &/$COUNTER inc %))
- (&/update$ &/$LOCALS #(&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)) %)))
+ (&/|cons (&/update$ &/$LOCALS #(->> %
+ (&/update$ &/$COUNTER inc)
+ (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m))))
+ (&/|head stack))
(&/|tail stack))))
state))]
(matchv ::M/objects [=return]
[["lux;Right" [?state ?value]]]
(return* (&/update$ &/$ENVS (fn [stack*]
- (&/|cons (->> (&/|head stack*)
- (&/update$ &/$LOCALS #(&/update$ &/$COUNTER dec %))
- (&/update$ &/$LOCALS #(&/set$ &/$MAPPINGS old-mappings %)))
- (&/|tail stack*)))
+ (&/|cons (&/update$ &/$LOCALS #(->> %
+ (&/update$ &/$COUNTER dec)
+ (&/set$ &/$MAPPINGS old-mappings))
+ (&/|head stack*))
+ (&/|tail stack*)))
?state)
?value)
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index b9361b8c3..3db4bd16d 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -352,7 +352,8 @@
)
(defn analyse-jvm-program [analyse ?args ?body]
- (|do [=body (&/with-scope ""
- (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text))
- (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))]
- (return (&/|list (&/V "jvm-program" =body)))))
+ (|let [[_module _name] ?args]
+ (|do [=body (&/with-scope ""
+ (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text))
+ (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))]
+ (return (&/|list (&/V "jvm-program" =body))))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 6bbcd0fcf..d02599f10 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -76,6 +76,15 @@
(|do [exo-type* (&type/deref ?id)]
(&type/actual-type exo-type*))
+ [["lux;AllT" _]]
+ (|do [$var &type/existential
+ =type (&type/apply-type exo-type $var)]
+ (&type/actual-type =type))
+ ;; (&type/with-var
+ ;; (fn [$var]
+ ;; (|do [=type (&type/apply-type exo-type $var)]
+ ;; (&type/actual-type =type))))
+
[_]
(&type/actual-type exo-type))
types (matchv ::M/objects [exo-type*]
@@ -83,7 +92,9 @@
(return ?table)
[_]
- (fail "[Analyser Error] The type of a record must be a record type."))
+ (fail (str "[Analyser Error] The type of a record must be a record type:\n"
+ (&type/show-type exo-type*)
+ "\n")))
=slots (&/map% (fn [kv]
(matchv ::M/objects [kv]
[[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]]
@@ -196,6 +207,9 @@
(|do [?fun-type* (&type/actual-type fun-type)]
(matchv ::M/objects [?fun-type*]
[["lux;AllT" _]]
+ ;; (|do [$var &type/existential
+ ;; type* (&type/apply-type ?fun-type* $var)]
+ ;; (analyse-apply* analyse exo-type type* ?args))
(&type/with-var
(fn [$var]
(|do [type* (&type/apply-type ?fun-type* $var)
@@ -216,6 +230,9 @@
=arg (&&/analyse-1 analyse ?input-t ?arg)]
(return (&/T =output-t (&/|cons =arg =args))))
+ ;; [["lux;VarT" ?id-t]]
+ ;; (|do [ (&type/deref ?id-t)])
+
[_]
(fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))))
))
@@ -229,7 +246,14 @@
(|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)]
(matchv ::M/objects [$def]
[["lux;MacroD" macro]]
- (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))]
+ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))
+ :let [_ (when (and ;; (= "lux/control/monad" ?module)
+ (= "do" ?name))
+ (->> (&/|map &/show-ast macro-expansion)
+ (&/|interpose "\n")
+ (&/fold str "")
+ (prn ?module "do")))]
+ ]
(&/flat-map% (partial analyse exo-type) macro-expansion))
[_]
@@ -254,16 +278,26 @@
exo-type)))))
(defn analyse-lambda* [analyse exo-type ?self ?arg ?body]
- (matchv ::M/objects [exo-type]
- [["lux;LambdaT" [?arg-t ?return-t]]]
- (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type
- ?arg ?arg-t
- (&&/analyse-1 analyse ?return-t ?body))]
- (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type)))
-
- [_]
- (fail (str "[Analyser Error] Functions require function types: "
- (&type/show-type exo-type)))))
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (matchv ::M/objects [exo-type]
+ [["lux;AllT" _]]
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-lambda* analyse exo-type** ?self ?arg ?body))))
+ ;; (|do [$var &type/existential
+ ;; exo-type** (&type/apply-type exo-type* $var)]
+ ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body))
+
+ [["lux;LambdaT" [?arg-t ?return-t]]]
+ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type*
+ ?arg ?arg-t
+ (&&/analyse-1 analyse ?return-t ?body))]
+ (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*)))
+
+ [_]
+ (fail (str "[Analyser Error] Functions require function types: "
+ (&type/show-type exo-type*))))))
(defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
(matchv ::M/objects [exo-type]
@@ -281,6 +315,14 @@
[["lux;ExT" _]]
(return (&/T _expr exo-type))
+ [["lux;VarT" ?_id]]
+ (|do [?? (&type/bound? ?_id)]
+ ;; (return (&/T _expr exo-type))
+ (if ??
+ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))
+ (return (&/T _expr exo-type)))
+ )
+
[_]
(fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))))
(return (&/T _expr exo-type))))))))
@@ -295,7 +337,7 @@
(return (&/|list output))))
(defn analyse-def [analyse ?name ?value]
- (prn 'analyse-def/BEGIN ?name)
+ ;; (prn 'analyse-def/BEGIN ?name)
(|do [module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
@@ -306,14 +348,16 @@
(matchv ::M/objects [=value]
[[["lux;Global" [?r-module ?r-name]] _]]
(|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type)
- :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name))
- _ (println)]]
+ ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name))
+ ;; _ (println)]
+ ]
(return (&/|list)))
[_]
(|do [=value-type (&&/expr-type =value)
- :let [_ (prn 'analyse-def/END ?name)
- _ (println)
+ :let [;; _ (prn 'analyse-def/END ?name)
+ _ (println 'DEF (str module-name ";" ?name))
+ ;; _ (println)
def-data (cond (&type/type= &type/Type =value-type)
(&/V "lux;TypeD" nil)
@@ -328,23 +372,32 @@
(return (&/|list (&/V "declare-macro" (&/T module-name ?name))))))
(defn analyse-import [analyse compile-module ?path]
- (prn 'analyse-import ?path)
- (fn [state]
- (let [already-compiled? (&/fold false #(or %1 (= %2 ?path)) (&/get$ &/$SEEN-SOURCES state))]
- (&/run-state (|do [_ (&&module/add-import ?path)
- _ (if already-compiled?
- (return nil)
- (compile-module ?path))]
- (return (&/|list)))
- (if already-compiled?
- state
- (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state))))))
+ (|do [module-name &/get-module-name]
+ (if (= module-name ?path)
+ (fail (str "[Analyser Error] Module can't import itself: " ?path))
+ (&/save-module
+ (fn [state]
+ (let [already-compiled? (&/fold #(or %1 (= %2 ?path)) false (&/get$ &/$SEEN-SOURCES state))]
+ (prn 'analyse-import module-name ?path already-compiled?)
+ (&/run-state (|do [_ (&&module/add-import ?path)
+ _ (if already-compiled?
+ (return nil)
+ (compile-module ?path))]
+ (return (&/|list)))
+ (if already-compiled?
+ state
+ (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state)))))))))
(defn analyse-export [analyse name]
(|do [module-name &/get-module-name
_ (&&module/export module-name name)]
(return (&/|list))))
+(defn analyse-alias [analyse ex-alias ex-module]
+ (|do [module-name &/get-module-name
+ _ (&&module/alias module-name ex-alias ex-module)]
+ (return (&/|list))))
+
(defn analyse-check [analyse eval! exo-type ?type ?value]
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
==type (eval! =type)
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index f0e5b82b4..27aa7374c 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -1,5 +1,6 @@
(ns lux.analyser.module
- (:require [clojure.core.match :as M :refer [matchv]]
+ (:require [clojure.string :as string]
+ [clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
(lux [base :as & :refer [|let |do return return* fail fail*]]
[type :as &type]
@@ -46,13 +47,14 @@
#(&/|put name (&/T false def-data) %)
m))
ms)))
- (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals]
- (&/update$ &/$MAPPINGS (fn [mappings]
- (&/|put (str "" &/+name-separator+ name)
- (&/T (&/V "lux;Global" (&/T module name)) type)
- mappings))
- locals))
- ?env))))
+ ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals]
+ ;; (&/update$ &/$MAPPINGS (fn [mappings]
+ ;; (&/|put (str "" &/+name-separator+ name)
+ ;; (&/T (&/V "lux;Global" (&/T module name)) type)
+ ;; mappings))
+ ;; locals))
+ ;; ?env)))
+ )
nil)
[_]
@@ -93,14 +95,15 @@
#(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %)
m))
ms)))
- (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals]
- (&/update$ &/$MAPPINGS (fn [mappings]
- (&/|put (str "" &/+name-separator+ a-name)
- (&/T (&/V "lux;Global" (&/T r-module r-name)) type)
- ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1)
- mappings))
- locals))
- ?env))))
+ ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals]
+ ;; (&/update$ &/$MAPPINGS (fn [mappings]
+ ;; (&/|put (str "" &/+name-separator+ a-name)
+ ;; (&/T (&/V "lux;Global" (&/T r-module r-name)) type)
+ ;; ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1)
+ ;; mappings))
+ ;; locals))
+ ;; ?env)))
+ )
nil)
[_]
@@ -112,7 +115,7 @@
(return* state
(->> state (&/get$ &/$MODULES) (&/|contains? name)))))
-(defn alias-module [module reference alias]
+(defn alias [module alias reference]
(fn [state]
(return* (->> state
(&/update$ &/$MODULES
@@ -136,23 +139,23 @@
(|do [current-module &/get-module-name]
(fn [state]
;; (prn 'find-def/_0 module name 'current-module current-module)
- (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))]
+ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
(do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module)))
- (if-let [$def (&/|get name $module)]
- (matchv ::M/objects [$def]
- [[exported? $$def]]
- (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module))
- (if (or exported? (.equals ^Object current-module module))
- (matchv ::M/objects [$$def]
- [["lux;AliasD" [?r-module ?r-name]]]
- (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name])
- ((find-def ?r-module ?r-name)
- state))
-
- [_]
- (return* state (&/T (&/T module name) $$def)))
- (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))))
- (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name)))))
+ (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))]
+ (matchv ::M/objects [$def]
+ [[exported? $$def]]
+ (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module))
+ (if (or exported? (.equals ^Object current-module module))
+ (matchv ::M/objects [$$def]
+ [["lux;AliasD" [?r-module ?r-name]]]
+ (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name])
+ ((find-def ?r-module ?r-name)
+ state))
+
+ [_]
+ (return* state (&/T (&/T module name) $$def)))
+ (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))))
+ (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))))
(do (prn [module name]
(str "[Analyser Error] Module doesn't exist: " module)
(->> state (&/get$ &/$MODULES) &/|keys &/->seq))
@@ -171,7 +174,7 @@
[[exported? ["lux;ValueD" ?type]]]
((|do [_ (&type/check &type/Macro ?type)
^ClassLoader loader &/loader
- :let [macro (-> (.loadClass loader (str module ".$" (&/normalize-ident name)))
+ :let [macro (-> (.loadClass loader (str (string/replace module #"/" ".") ".$" (&/normalize-ident name)))
(.getField "_datum")
(.get nil))]]
(fn [state*]
@@ -191,9 +194,9 @@
(fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name)))
[[_ ["lux;TypeD" _]]]
- (fail* (str "[Analyser Error] Definition doesn't have macro type: " module ";" name)))
- (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))
- (fail* (str "[Analyser Error] Module doesn't exist: " module)))))
+ (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name))))
+ (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))
+ (fail* (str "[Analyser Error] Module does not exist: " module)))))
(defn export [module name]
(fn [state]
@@ -213,7 +216,7 @@
m))
ms))))
nil))
- (fail* (str "[Analyser Error] Can't export an inexistent definition: " module ";" name)))
+ (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name))))
[_]
(fail* "[Analyser Error] Can't export a global definition outside of a global environment."))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index aecb3fd13..d88bb2ec1 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -483,13 +483,25 @@
;; "lux;seed"
0
;; "lux;seen-sources"
- (|list)
+ (|list "lux")
;; "lux;source"
(V "lux;None" nil)
;; "lux;types"
+init-bindings+
))
+(defn save-module [body]
+ (fn [state]
+ (matchv ::M/objects [(body state)]
+ [["lux;Right" [state* output]]]
+ (return* (->> state*
+ (set$ $ENVS (get$ $ENVS state))
+ (set$ $SOURCE (get$ $SOURCE state)))
+ output)
+
+ [["lux;Left" msg]]
+ (fail* msg))))
+
(defn with-eval [body]
(fn [state]
(matchv ::M/objects [(body (set$ $EVAL? true state))]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 1970c548a..04f4fb4c2 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -342,7 +342,7 @@
.visitEnd))]
_ (&&/save-class! (str id) bytecode)
loader &/loader]
- (-> (.loadClass ^ClassLoader loader (str module "." id))
+ (-> (.loadClass ^ClassLoader loader (str (string/replace module #"/" ".") "." id))
(.getField "_eval")
(.get nil)
return))))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index bc1ab23f1..2a8bdac89 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -146,7 +146,7 @@
compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I"
)
-(do-template [<name> <cmpcode> <ifcode> <wrapper-class> <value-method> <value-method-sig>]
+(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>]
(defn <name> [compile *type* ?x ?y]
(|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
@@ -162,25 +162,26 @@
$end (new Label)
_ (doto *writer*
(.visitInsn <cmpcode>)
- (.visitJumpInsn <ifcode> $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean"))
+ (.visitLdcInsn (int <cmp-output>))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean"))
(.visitJumpInsn Opcodes/GOTO $end)
(.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean"))
+ (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean"))
(.visitLabel $end))]]
(return nil)))
- compile-jvm-leq Opcodes/LCMP Opcodes/IFEQ "java.lang.Long" "longValue" "()J"
- compile-jvm-llt Opcodes/LCMP Opcodes/IFLT "java.lang.Long" "longValue" "()J"
- compile-jvm-lgt Opcodes/LCMP Opcodes/IFGT "java.lang.Long" "longValue" "()J"
+ compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J"
+ compile-jvm-llt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J"
+ compile-jvm-lgt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J"
- compile-jvm-feq Opcodes/FCMPG Opcodes/IFEQ "java.lang.Float" "floatValue" "()F"
- compile-jvm-flt Opcodes/FCMPG Opcodes/IFLT "java.lang.Float" "floatValue" "()F"
- compile-jvm-fgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Float" "floatValue" "()F"
+ compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F"
+ compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F"
+ compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F"
- compile-jvm-deq Opcodes/DCMPG Opcodes/IFEQ "java.lang.Double" "doubleValue" "()I"
- compile-jvm-dlt Opcodes/DCMPG Opcodes/IFLT "java.lang.Double" "doubleValue" "()I"
- compile-jvm-dgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Double" "doubleValue" "()I"
+ compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I"
+ compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I"
+ compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I"
)
(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index ecb614732..7d6b2b502 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -25,6 +25,17 @@
:let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]]
(return nil)))
+(defn compile-int [compile *type* value]
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW "java/lang/Long")
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (bit-shift-left (long value) 0)
+ ;; (bit-shift-left (long value) 32)
+ )
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Long" "<init>" "(J)V"))]]
+ (return nil)))
+
(do-template [<name> <class> <sig> <caster>]
(defn <name> [compile *type* value]
(|do [^MethodVisitor *writer* &/get-writer
@@ -35,7 +46,7 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]]
(return nil)))
- compile-int "java/lang/Long" "(J)V" long
+ ;; compile-int "java/lang/Long" "(J)V" long
compile-real "java/lang/Double" "(D)V" double
compile-char "java/lang/Character" "(C)V" char
)
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index a137ca863..fbfe1f757 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -67,8 +67,8 @@
(return (&/V "lux;Meta" (&/T meta (&/V <tag> token))))))
^:private lex-bool "Bool" #"^(true|false)"
- ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)"
- ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+"
+ ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)"
+ ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)"
)
(def ^:private lex-char
@@ -89,14 +89,14 @@
(def ^:private lex-ident
(&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)]
(&/try-all% (&/|list (|do [_ (&reader/read-text ";")
- [_ local-token] (&reader/read-regex +ident-re+)]
- (&/try-all% (&/|list (|do [unaliased (&module/dealias token)]
- (return (&/T meta (&/T unaliased local-token))))
- (|do [? (&module/exists? token)]
- (if ?
- (return (&/T meta (&/T token local-token)))
- (fail (str "[Lexer Error] Unknown module: " token))))
- )))
+ [_ local-token] (&reader/read-regex +ident-re+)
+ ? (&module/exists? token)]
+ (if ?
+ (return (&/T meta (&/T token local-token)))
+ (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token)
+ (&module/dealias token))]
+ (do ;; (prn "Unaliased: " unaliased ";" local-token)
+ (return (&/T meta (&/T unaliased local-token)))))))
(return (&/T meta (&/T "" token)))
)))
(|do [[meta _] (&reader/read-text ";;")
diff --git a/src/lux/type.clj b/src/lux/type.clj
index e0315f8e7..e7d6353e8 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -349,16 +349,18 @@
(str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
[["lux;VariantT" cases]]
- (str "(| " (->> cases
- (&/|map (fn [kv]
- (matchv ::M/objects [kv]
- [[k ["Tuple" ["Nil" _]]]]
- (str "#" k)
-
- [[k v]]
- (str "(#" k " " (show-type v) ")"))))
- (&/|interpose " ")
- (&/fold str "")) ")")
+ (if (&/|empty? cases)
+ "(|)"
+ (str "(| " (->> cases
+ (&/|map (fn [kv]
+ (matchv ::M/objects [kv]
+ [[k ["lux;TupleT" ["lux;Nil" _]]]]
+ (str "#" k)
+
+ [[k v]]
+ (str "(#" k " " (show-type v) ")"))))
+ (&/|interpose " ")
+ (&/fold str "")) ")"))
[["lux;RecordT" fields]]
@@ -485,7 +487,9 @@
(&/|cons (&/T k v) fixpoints))
(defn ^:private check-error [expected actual]
- (str "Type " (show-type expected) " does not subsume type " (show-type actual)))
+ (str "[Type Checker]\nExpected: " (show-type expected)
+ "\n\nActual: " (show-type actual)
+ "\n"))
(defn beta-reduce [env type]
(matchv ::M/objects [type]
@@ -555,7 +559,7 @@
(apply-type type-fn* param))
[_]
- (fail (str "[Type System] Can't apply type function " (show-type type-fn) " to type " (show-type param)))))
+ (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n"))))
(def init-fixpoints (&/|list))
@@ -826,10 +830,10 @@
[["lux;ExT" e!id] ["lux;ExT" a!id]]
(if (.equals ^Object e!id a!id)
(return (&/T fixpoints nil))
- (check-error expected actual))
+ (fail (check-error expected actual)))
[_ _]
- (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual)))
+ (fail (check-error expected actual))
)))
(defn check [expected actual]
@@ -850,7 +854,7 @@
(clean $var =return))))
[_]
- (fail (str "[Type System] Can't apply type " (show-type func) " to type " (show-type param)))
+ (fail (str "[Type System] Not a function type:\n" (show-type func) "\n"))
))
(defn actual-type [type]
@@ -859,6 +863,9 @@
(|do [type* (apply-type ?all ?param)]
(actual-type type*))
+ [["lux;VarT" ?id]]
+ (deref ?id)
+
[_]
(return type)
))