aboutsummaryrefslogtreecommitdiff
path: root/input/lux.lux
diff options
context:
space:
mode:
Diffstat (limited to 'input/lux.lux')
-rw-r--r--input/lux.lux1400
1 files changed, 1001 insertions, 399 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")))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-23 07:50:25 +0000