diff options
| author | Eduardo Julian | 2015-07-31 20:33:29 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2015-07-31 20:33:29 -0400 |
| commit | c9e0b6c3a0c23b34cd6ffac1b93a266ae6243c4a (patch) | |
| tree | faf96e94ba0bf7dd762e2af05662fc24c8d90690 | |
| parent | 3b0b7de8d898662ba154aa8cbd578d26fb91e62e (diff) | |
- Did some refactoring of the standard library.
- Introduced 2 new modules: lux/data/tuple & lux/codata/function
- Now doing safe reading of files.
- Took the "let", "lambda" & "def" macros to their ultimate form.
- Added some macros for doing better JVM interop.
- Fixed a bug when compiling comparisons for doubles.
- Changed the order in which arguments are compiled for all arithmetic operations, as the order is reversed (from the conventional order) in the JVM bytecode.
32 files changed, 1219 insertions, 828 deletions
@@ -102,7 +102,7 @@ The mechanism hasn't been added yet to the language (mainly because there's only ### Macros Unlike in most other lisps, Lux macros are monadic. -The **(Lux a)** type is the one responsibly for the magic by treading **Compiler** instances through macros. +The **(Lux a)** type is the one responsible for the magic by treading **Compiler** instances through macros. Macros must have the **Macro** type and then be declared as macros. However, just using the **defmacro** macro will take care of it for you. diff --git a/source/lux.lux b/source/lux.lux index 8861bc241..dc186fb3d 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -373,7 +373,7 @@ (_lux_lambda _ tokens (_meta (#RecordS tokens))))) -(_lux_def let' +(_lux_def let'' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens @@ -383,10 +383,10 @@ #Nil])) _ - (fail "Wrong syntax for let'"))))) -(_lux_declare-macro let') + (fail "Wrong syntax for let''"))))) +(_lux_declare-macro let'') -(_lux_def lambda' +(_lux_def lambda'' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens @@ -399,7 +399,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -414,7 +414,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -422,73 +422,73 @@ _ (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda') +(_lux_declare-macro lambda'') -(_lux_def def' +(_lux_def def'' (_lux_: Macro - (lambda' [tokens] - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) + (lambda'' [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) - _ - (fail "Wrong syntax for def") - )))) -(_lux_declare-macro def') + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def'') -(def' (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'"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) (#Cons [body @@ -498,7 +498,7 @@ #Nil])])) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -587,7 +587,7 @@ _ (fail "Wrong syntax for $'"))) -(def' (foldL f init xs) +(def'' (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -600,18 +600,18 @@ (#Cons [x xs']) (foldL f (f init x) xs'))) -(def' (reverse list) +(def'' (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (lambda' [tail head] (#Cons [head tail])) + (foldL (lambda'' [tail head] (#Cons [head tail])) #Nil list)) (defmacro (list xs) - (return (#Cons [(foldL (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) + (return (#Cons [(foldL (lambda'' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) (_meta (#TagS ["lux" "Nil"])) (reverse xs)) #Nil]))) @@ -619,45 +619,45 @@ (defmacro (list& xs) (_lux_case (reverse xs) (#Cons [last init]) - (return (list (foldL (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) + (return (list (foldL (lambda'' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) last init))) _ (fail "Wrong syntax for list&"))) -(defmacro #export (lambda tokens) - (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ name) - harg - (foldL (lambda' [body' arg] - (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))) - - _ - (fail "Wrong syntax for lambda")))) +(defmacro (lambda' tokens) + (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] -(defmacro (def'' tokens) + _ + [["" ""] tokens])) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda' requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ name) + harg + (foldL (lambda'' [body' arg] + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda'")))) + +(defmacro (def''' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -666,7 +666,7 @@ name (form$ (list (symbol$ ["" "_lux_:"]) type - (form$ (list (symbol$ ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda'"]) name (tuple$ args) body)))))) @@ -686,7 +686,7 @@ name (form$ (list (symbol$ ["" "_lux_:"]) type - (form$ (list (symbol$ ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda'"]) name (tuple$ args) body)))))))) @@ -697,10 +697,10 @@ (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) _ - (fail "Wrong syntax for def") + (fail "Wrong syntax for def'") )) -(def'' (as-pairs xs) +(def''' (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs @@ -710,22 +710,22 @@ _ #Nil)) -(defmacro #export (let tokens) +(defmacro (let' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) + (lambda' [body binding] + (_lux_case binding + [label value] + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) body (reverse (as-pairs bindings))))) _ - (fail "Wrong syntax for let"))) + (fail "Wrong syntax for let'"))) -(def'' (map f xs) +(def''' (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -735,7 +735,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def'' (any? p xs) +(def''' (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs @@ -747,7 +747,7 @@ true true false (any? p xs')))) -(def'' (spliced? token) +(def''' (spliced? token) (->' Syntax Bool) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) @@ -756,13 +756,13 @@ _ false)) -(def'' (wrap-meta content) +(def''' (wrap-meta content) (->' Syntax Syntax) (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) content))))))) -(def'' (untemplate-list tokens) +(def''' (untemplate-list tokens) (->' ($' List Syntax) Syntax) (_lux_case tokens #Nil @@ -772,7 +772,7 @@ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def'' #export (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']) @@ -784,41 +784,41 @@ (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))) _ (fail "Wrong syntax for $"))) -(def'' (splice replace? untemplate tag elems) +(def''' (splice replace? untemplate tag elems) (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_lux_case replace? true (_lux_case (any? spliced? elems) true - (let [elems' (map (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - (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:++"]) - elems')))))) + (let' [elems' (map (lambda' [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + (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:++"]) + elems')))))) false (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) false (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) -(def'' (untemplate replace? subst token) +(def''' (untemplate replace? subst token) (->' Bool Text Syntax Syntax) (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) [_ (#Meta [_ (#BoolS value)])] @@ -837,22 +837,22 @@ (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) [_ (#Meta [_ (#TagS [module name])])] - (let [module' (_lux_case module - "" - subst + (let' [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) [_ (#Meta [_ (#SymbolS [module name])])] - (let [module' (_lux_case module - "" - subst + (let' [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) [_ (#Meta [_ (#TupleS elems)])] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) @@ -861,15 +861,15 @@ unquoted [_ (#Meta [meta (#FormS elems)])] - (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - (#Meta [meta form'])) + (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + (#Meta [meta form'])) [_ (#Meta [_ (#RecordS fields)])] (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 replace? subst k) (untemplate replace? subst v)))))) + (lambda' [kv] + (let' [[k v] kv] + (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) fields))))) )) @@ -881,7 +881,7 @@ _ (fail "Wrong syntax for `'"))) -(defmacro (' tokens) +(defmacro #export (' tokens) (_lux_case tokens (#Cons [template #Nil]) (return (list (untemplate false "" template))) @@ -892,16 +892,16 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (lambda [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) + (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))) + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) + _ + (`' ((~ app) (~ acc))))) init apps))) @@ -920,7 +920,7 @@ ## (deftype (Lux a) ## (-> Compiler (Either Text (, Compiler a)))) -(def'' #export Lux +(def''' #export Lux Type (All' [a] (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) @@ -930,7 +930,7 @@ ## return) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) -(def'' Monad +(def''' Monad Type (All' [m] (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] @@ -938,34 +938,34 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def'' Maybe/Monad +(def''' Maybe/Monad ($' Monad Maybe) {#lux;return - (lambda return [x] - (#Some x)) + (lambda' return [x] + (#Some x)) #lux;bind - (lambda [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) + (lambda' [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) -(def'' Lux/Monad +(def''' Lux/Monad ($' Monad Lux) {#lux;return - (lambda [x] - (lambda [state] - (#Right [state x]))) + (lambda' [x] + (lambda' [state] + (#Right [state x]))) #lux;bind - (lambda [f ma] - (lambda [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) + (lambda' [f ma] + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right [state' a]) - (f a state'))))}) + (#Right [state' a]) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens @@ -978,7 +978,7 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons [output inputs]) - (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + (return (list (foldL (lambda' [o i] (`' (#;LambdaT [(~ i) (~ o)]))) output inputs))) @@ -991,28 +991,28 @@ (defmacro (do tokens) (_lux_case tokens (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) + (let' [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda' [body' binding] + (let' [[var value] binding] + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let' (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) _ (fail "Wrong syntax for do"))) -(def'' (map% m f xs) +(def''' (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] @@ -1020,25 +1020,25 @@ (-> (B' a) ($' (B' m) (B' b))) ($' List (B' a)) ($' (B' m) ($' List (B' b))))) - (let [{#;return ;return #;bind _} m] - (_lux_case xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) + (let' [{#;return ;return #;bind _} m] + (_lux_case xs + #Nil + (;return #Nil) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (#Cons [y ys]))) + ))) -(def'' #export (. f g) +(def''' (. f g) (All' [a b c] (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) - (lambda [x] - (f (g x)))) + (lambda' [x] + (f (g x)))) -(def'' (get-ident x) +(def''' (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1047,7 +1047,7 @@ _ #None)) -(def'' (tuple->list tuple) +(def''' (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple (#Meta [_ (#TupleS members)]) @@ -1056,11 +1056,11 @@ _ #None)) -(def'' RepEnv +(def''' RepEnv Type ($' List (, Text Syntax))) -(def'' (make-env xs ys) +(def''' (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) [xs ys]) @@ -1070,12 +1070,12 @@ _ #Nil)) -(def'' (text:= x y) +(def''' (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y])) -(def'' (get-rep key env) +(def''' (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) (_lux_case env #Nil @@ -1086,7 +1086,7 @@ (#Some v) (get-rep key env')))) -(def'' (apply-template env template) +(def''' (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template (#Meta [_ (#SymbolS ["" sname])]) @@ -1105,15 +1105,15 @@ (#Meta [_ (#RecordS members)]) (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) + (lambda' [kv] + (let' [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) members)) _ template)) -(def'' (join-map f xs) +(def''' (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -1130,11 +1130,11 @@ [(map% Maybe/Monad get-ident bindings) (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] - (let [apply (_lux_: (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) + (let' [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda' [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) _ (fail "Wrong syntax for do-template")) @@ -1143,7 +1143,7 @@ (fail "Wrong syntax for do-template"))) (do-template [<name> <cmp> <type>] - [(def'' #export (<name> x y) + [(def''' (<name> x y) (-> <type> <type> Bool) (<cmp> x y))] @@ -1156,7 +1156,7 @@ ) (do-template [<name> <cmp> <eq> <type>] - [(def'' #export (<name> x y) + [(def''' (<name> x y) (-> <type> <type> Bool) (if (<cmp> x y) true @@ -1169,7 +1169,7 @@ ) (do-template [<name> <cmp> <type>] - [(def'' #export (<name> x y) + [(def''' (<name> x y) (-> <type> <type> <type>) (<cmp> x y))] @@ -1185,29 +1185,29 @@ [r% _jvm_drem Real] ) -(def'' (multiple? div n) +(def''' (multiple? div n) (-> Int Int Bool) (i= 0 (i% n div))) -(def'' (length list) +(def''' (length list) (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + (foldL (lambda' [acc _] (_jvm_ladd 1 acc)) 0 list)) -(def'' #export (not x) +(def''' #export (not x) (-> Bool Bool) (if x false true)) -(def'' (text:++ x y) +(def''' (text:++ x y) (-> Text Text Text) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y])) -(def'' (ident->text ident) +(def''' (ident->text ident) (-> Ident Text) - (let [[module name] ident] - ($ text:++ module ";" name))) + (let' [[module name] ident] + ($ text:++ module ";" name))) -(def'' (replace-syntax reps syntax) +(def''' (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax (#Meta [_ (#SymbolS ["" name])]) @@ -1226,9 +1226,9 @@ (#Meta [_ (#RecordS slots)]) (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) + (lambda' [slot] + (let' [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) slots))]) _ @@ -1236,40 +1236,40 @@ ) (defmacro #export (All tokens) - (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) - (#Some idents) - (_lux_case idents - #Nil - (return (list body)) + (let' [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe/Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (list body)) + + (#Cons [harg targs]) + (let' [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) + (list& self-ident idents)) + body' (foldL (lambda' [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) + (replace-syntax replacements body) + (reverse targs))] + ## (#;Some #;Nil) + (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) + + #None + (fail "'All' arguments must be symbols.")) - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) - (list& self-ident idents)) - body' (foldL (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - ## (#;Some #;Nil) - (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) + _ + (fail "Wrong syntax for All")) + )) -(def'' (get k plist) +(def''' (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (_lux_case plist @@ -1281,7 +1281,7 @@ #Nil #None)) -(def'' (put k v dict) +(def''' (put k v dict) (All [a] (-> Text a ($' List (, Text a)) ($' List (, Text a)))) (_lux_case dict @@ -1293,7 +1293,7 @@ (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')])))) -(def'' (get-module-name state) +(def''' (get-module-name state) ($' Lux Text) (_lux_case state {#source source #modules modules @@ -1306,14 +1306,14 @@ (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) (#Right [state module-name])))) -(def'' (find-macro' modules current-module module name) +(def''' (find-macro' modules current-module module name) (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) (do Maybe/Monad [$module (get module modules) - gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] + gdef (let' [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] (if exported? @@ -1328,24 +1328,24 @@ _ #None))) -(def'' (find-macro ident) +(def''' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux/Monad [current-module get-module-name] - (let [[module name] ident] - (lambda [state] - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [state (find-macro' modules current-module module name)])))))) - -(def'' (list:join xs) + (let' [[module name] ident] + (lambda' [state] + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [state (find-macro' modules current-module module name)])))))) + +(def''' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (foldL list:++ #Nil xs)) -(def'' (normalize ident) +(def''' (normalize ident) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] @@ -1360,20 +1360,20 @@ (do Lux/Monad [pairs (map% Lux/Monad (_lux_: (-> Syntax ($' Lux Syntax)) - (lambda [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux/Monad - [ident (normalize 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)]))) - - _ - (fail "Wrong syntax for |")))) + (lambda' [token] + (_lux_case token + (#Meta [_ (#TagS ident)]) + (do Lux/Monad + [ident (normalize 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)]))) + + _ + (fail "Wrong syntax for |")))) tokens)] (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) @@ -1383,23 +1383,23 @@ (do Lux/Monad [pairs (map% Lux/Monad (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) + (lambda' [pair] + (_lux_case pair + [(#Meta [_ (#TagS ident)]) value] + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for &")))) (as-pairs tokens))] (;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'' (interpose sep xs) +(def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1412,7 +1412,7 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def'' (macro-expand syntax) +(def''' (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) @@ -1445,7 +1445,7 @@ _ (return (list syntax)))) -(def'' (walk-type type) +(def''' (walk-type type) (-> Syntax Syntax) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) @@ -1455,7 +1455,7 @@ (tuple$ (map walk-type members)) (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (foldL (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1493,71 +1493,71 @@ _ (fail "Wrong syntax for :!"))) -(def'' (empty? xs) +(def''' (empty? xs) (All [a] (-> ($' List a) Bool)) (_lux_case xs #Nil true _ false)) (defmacro #export (deftype tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] + (let' [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + [rec? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + [true tokens'] - _ - [false tokens])) - [rec? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) - [true tokens'] - - _ - [false tokens'])) - parts (: (Maybe (, Text (List Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) + _ + [false tokens'])) + parts (: (Maybe (, Text (List Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) + (#Some [name #Nil type]) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) + (#Some [name args type]) - _ - #None))] - (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) - #Nil)) - type' (: (Maybe Syntax) - (if rec? - (if (empty? args) - (let [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) - with-export)) + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let' [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ (symbol$ ["" name]))))) + #Nil)) + type' (: (Maybe Syntax) + (if rec? + (if (empty? args) + (let' [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) + + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + with-export)) + + #None + (fail "Wrong syntax for deftype"))) #None - (fail "Wrong syntax for deftype"))) - - #None - (fail "Wrong syntax for deftype")) - )) + (fail "Wrong syntax for deftype")) + )) ## (defmacro #export (deftype tokens) -## (let [[export? tokens'] (: (, Bool (List Syntax)) +## (let' [[export? tokens'] (: (, Bool (List Syntax)) ## (_lux_case (:! (List Syntax) tokens) ## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) ## [true (:! (List Syntax) tokens')] @@ -1576,7 +1576,7 @@ ## #None))] ## (_lux_case parts ## (#Some [name args type]) -## (let [with-export (: (List Syntax) +## (let' [with-export (: (List Syntax) ## (if export? ## (list (`' (_lux_export (~ name)))) ## #Nil)) @@ -1597,66 +1597,66 @@ (defmacro #export (exec tokens) (_lux_case (reverse tokens) (#Cons [value actions]) - (let [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) - value - actions)))) + (let' [dummy (symbol$ ["" ""])] + (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) _ (fail "Wrong syntax for exec"))) -(defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] +(defmacro (def' tokens) + (let' [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) - - _ - #None))] - (_lux_case parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (_lux_case args - #Nil - body + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let' [body' (: Syntax + (_lux_case args + #Nil + body - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) + _ + (`' (;lambda' (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) + + #None + body'))] + (return (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for def'")))) -(def (rejoin-pair pair) +(def' (rejoin-pair pair) (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) + (let' [[left right] pair] + (list left right))) (defmacro #export (case tokens) (_lux_case tokens @@ -1664,17 +1664,17 @@ (do Lux/Monad [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)))))) + (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)))))) (as-pairs branches))] (;return (list (`' (_lux_case (~ value) (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) @@ -1707,18 +1707,12 @@ _ (do Lux/Monad [patterns' (map% Lux/Monad macro-expand patterns)] - (;return (list:join (map (lambda [pattern] (list pattern body)) + (;return (list:join (map (lambda' [pattern] (list pattern body)) (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) -(do-template [<name> <offset>] - [(def #export <name> (i+ <offset>))] - - [inc 1] - [dec -1]) - (defmacro #export (` tokens) (do Lux/Monad [module-name get-module-name] @@ -1729,6 +1723,147 @@ _ (fail "Wrong syntax for `")))) +(def' (symbol? ast) + (-> Syntax Bool) + (case ast + (#Meta [_ (#SymbolS _)]) + true + + _ + false)) + +(defmacro #export (let tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS bindings)]) body)) + (if (multiple? 2 (length bindings)) + (|> bindings as-pairs reverse + (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda' [body' lr] + (let' [[l r] lr] + (if (symbol? l) + (` (_lux_case (~ r) (~ l) (~ body'))) + (` (case (~ r) (~ l) (~ body'))))))) + body) + list + return) + (fail "let requires an even number of parts")) + + _ + (fail "Wrong syntax for let"))) + +(def' (ast:show ast) + (-> Syntax Text) + (case ast + (#Meta [_ ast]) + (case ast + (\or (#BoolS val) (#IntS val) (#RealS val)) + (->text val) + + (#CharS val) + ($ text:++ "#\"" (->text val) "\"") + + (#TextS val) + ($ text:++ "\"" (->text val) "\"") + + (#FormS parts) + ($ text:++ "(" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) ")") + + (#TupleS parts) + ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") + + (#SymbolS [prefix name]) + ($ text:++ prefix ";" name) + + (#TagS [prefix name]) + ($ text:++ "#" prefix ";" name) + + (#RecordS kvs) + ($ text:++ "{" + (|> kvs + (map (: (-> (, Syntax Syntax) Text) + (lambda' [kv] (let [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v)))))) + (interpose " ") + (foldL text:++ "")) + "}") + ))) + +(defmacro #export (lambda tokens) + (case (: (Maybe (, Ident Syntax (List Syntax) Syntax)) + (case tokens + (\ (list (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) + (#Some [["" ""] head tail body]) + + (\ (list (#Meta [_ (#SymbolS ident)]) (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) + (#Some [ident head tail body]) + + _ + #None)) + (#Some [ident head tail body]) + (let [g!blank (symbol$ ["" ""]) + g!name (symbol$ ident) + body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax) + (lambda' [body' arg] + (if (symbol? arg) + (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail)))] + (return (list (if (symbol? head) + (` (_lux_lambda (~ g!name) (~ head) (~ body+))) + (` (_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) + + #None + (fail "Wrong syntax for lambda"))) + +(defmacro #export (def tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (case tokens' + (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) type body)) + (#Some [name args (#Some type) body]) + + (\ (list name type body)) + (#Some [name #Nil (#Some type) body]) + + (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) body)) + (#Some [name args #None body]) + + (\ (list name body)) + (#Some [name #Nil #None body]) + + _ + #None))] + (case parts + (#Some [name args ?type body]) + (let [body (: Syntax + (case args + #Nil + body + + _ + (` (;lambda (~ name) [(~@ args)] (~ body))))) + body (: Syntax + (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body))] + (return (list& (` (_lux_def (~ name) (~ body))) + (if export? + (list (` (_lux_export (~ name)))) + (list))))) + + #None + (fail "Wrong syntax for def")))) + (def (gensym prefix state) (-> Text (Lux Syntax)) (case state @@ -1737,7 +1872,7 @@ #seed seed #eval? eval?} (#Right [{#source source #modules modules #envs envs #types types #host host - #seed (inc seed) #eval? eval?} + #seed (i+ 1 seed) #eval? eval?} (symbol$ ["__gensym__" (->text seed)])]))) (def (macro-expand-1 token) @@ -1758,7 +1893,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) (do Lux/Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1766,12 +1901,12 @@ _ (fail "Signatures require typed 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))))))))) + (;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)) @@ -1796,13 +1931,13 @@ (let [sigs' (: Syntax (case args #Nil - (`' (;sig (~@ sigs))) + (` (;sig (~@ sigs))) _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (_lux_def (~ name) (~ sigs'))) + (` (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (` (_lux_def (~ name) (~ sigs'))) (if export? - (list (`' (_lux_export (~ name)))) + (list (` (_lux_export (~ name)))) #Nil)))) #None @@ -1815,13 +1950,13 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) (do Lux/Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [(tag$ name') value]))) _ - (fail "Structures require defined members!")))) + (fail "Structures require defined members")))) (list:join tokens'))] (;return (list (record$ members))))) @@ -1848,13 +1983,13 @@ (let [defs' (: Syntax (case args #Nil - (`' (;struct (~@ defs))) + (` (;struct (~@ defs))) _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (` (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (` (def (~ name) (~ type) (~ defs'))) (if export? - (list (`' (_lux_export (~ name)))) + (list (` (_lux_export (~ name)))) #Nil)))) #None @@ -2071,7 +2206,7 @@ (if (i< idx 0) (#Cons [module #Nil]) (#Cons [(substring2 0 idx module) - (split-module (substring1 (inc idx) module))])))) + (split-module (substring1 (i+ 1 idx) module))])))) (def (@ idx xs) (All [a] @@ -2083,7 +2218,7 @@ (#Cons [x xs']) (if (i= idx 0) (#Some x) - (@ (dec idx) xs') + (@ (i- idx 1) xs') ))) (def (split-with' p ys xs) @@ -2213,7 +2348,7 @@ (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) (map (: (-> Text Syntax) (lambda [def] - (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) defs) openings)))))) imports)] @@ -2244,7 +2379,7 @@ (-> Text (, Text Text)) (let [idx (index-of ";" slot) module (substring2 0 idx slot) - name (substring1 (inc idx) slot)] + name (substring1 (i+ 1 idx) slot)] [module name])) (def (type:show type) @@ -2363,26 +2498,13 @@ 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)) + (#Some (beta-reduce (|> (case env + (#Some env) env + _ (list)) (put name type-fn) (put arg param)) body)) @@ -2542,27 +2664,12 @@ _ (fail "Wrong syntax for using"))) -(def #export (flip f) +(def (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) (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 [xy] - (let [[x y] xy] - (f x y)))) - (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux new file mode 100644 index 000000000..3c40df188 --- /dev/null +++ b/source/lux/codata/function.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 + (lux/control (monoid #as m))) + +## [Functions] +(def #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] (f x y))) + +(def #export (. f g) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (lambda [x] (f (g x)))) + +## [Structures] +(defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) + (def m;unit id) + (def m;++ .)) diff --git a/source/lux/control/lazy.lux b/source/lux/codata/lazy.lux index 22dac74fe..94968de20 100644 --- a/source/lux/control/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -7,10 +7,11 @@ ## 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)) + (lux (meta macro) + (control (functor #as F #refer #all) + (monad #as M #refer #all)) + (data list)) + (.. function)) ## Types (deftype #export (Lazy a) diff --git a/source/lux/data/reader.lux b/source/lux/codata/reader.lux index e91687c3a..e91687c3a 100644 --- a/source/lux/data/reader.lux +++ b/source/lux/codata/reader.lux diff --git a/source/lux/data/state.lux b/source/lux/codata/state.lux index bc9858a29..bc9858a29 100644 --- a/source/lux/data/state.lux +++ b/source/lux/codata/state.lux diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 1d6dd1b50..2c854a61c 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -7,14 +7,15 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (control (lazy #as L #refer #all) - (functor #as F #refer #all) + (lux (control (functor #as F #refer #all) (monad #as M #refer #all) (comonad #as CM #refer #all)) (meta lux macro syntax) - (data (list #as l #refer (#only list list& List/Monad))))) + (data (list #as l #refer (#only list list& List/Monad)) + (number (int #open ("i" Int/Number Int/Ord)))) + (codata (lazy #as L #refer #all)))) ## [Types] (deftype #export (Stream a) @@ -59,7 +60,7 @@ (All [a] (-> Int (Stream a) a)) (let [[h t] (! s)] (if (i> idx 0) - (@ (dec idx) t) + (@ (i+ -1 idx) t) h))) (do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>] @@ -89,7 +90,7 @@ [(list) xs])))] [take-while drop-while split-with (-> a Bool) (det x) det] - [take drop split Int (i> det 0) (dec det)] + [take drop split Int (i> det 0) (i+ -1 det)] ) (def #export (unfold step init) diff --git a/source/lux/data/bounded.lux b/source/lux/control/bounded.lux index 9d2dabde1..9d2dabde1 100644 --- a/source/lux/data/bounded.lux +++ b/source/lux/control/bounded.lux diff --git a/source/lux/control/dict.lux b/source/lux/control/dict.lux new file mode 100644 index 000000000..3089ec927 --- /dev/null +++ b/source/lux/control/dict.lux @@ -0,0 +1,21 @@ +## 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 (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)) diff --git a/source/lux/data/eq.lux b/source/lux/control/eq.lux index be3400208..be3400208 100644 --- a/source/lux/data/eq.lux +++ b/source/lux/control/eq.lux diff --git a/source/lux/control/number.lux b/source/lux/control/number.lux new file mode 100644 index 000000000..40906a8a8 --- /dev/null +++ b/source/lux/control/number.lux @@ -0,0 +1,28 @@ +## 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 (monoid #as m) + (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## [Signatures] +(defsig #export (Number n) + (do-template [<name>] + [(: (-> n n n) <name>)] + [+] [-] [*] [/] [%]) + + (do-template [<name>] + [(: (-> n n) <name>)] + [negate] [signum] [abs]) + + (: (-> Int n) + from-int) + ) diff --git a/source/lux/data/ord.lux b/source/lux/control/ord.lux index 80f2e4fb5..80f2e4fb5 100644 --- a/source/lux/data/ord.lux +++ b/source/lux/control/ord.lux diff --git a/source/lux/data/show.lux b/source/lux/control/show.lux index f4e1cf762..f4e1cf762 100644 --- a/source/lux/data/show.lux +++ b/source/lux/control/show.lux diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index d4f223612..5f4427a2c 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -7,9 +7,9 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (show #as S))) + (lux/control (monoid #as m) + (eq #as E) + (show #as S))) ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 5a811c006..b97ec644d 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -7,9 +7,9 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (.. (eq #as E) - (show #as S) - (text #as T #open ("text:" Text/Monoid)))) + (lux/control (eq #as E) + (show #as S)) + (.. (text #as T #open ("text:" Text/Monoid)))) ## [Structures] (defstruct #export Char/Eq (E;Eq Char) diff --git a/source/lux/data/cont.lux b/source/lux/data/cont.lux new file mode 100644 index 000000000..51c6ece87 --- /dev/null +++ b/source/lux/data/cont.lux @@ -0,0 +1,41 @@ +## 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 (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Cont r a) + (-> (-> a r) r)) + +## [Structures] +(defstruct #export Cont/Functor (All [r] + (Functor (Cont r))) + (def (F;map f fa) + (lambda [k] + (k (fa f))))) + +(defstruct #export Cont/Monad (All [r] + (Monad (Cont r))) + (def M;_functor Cont/Functor) + + (def (M;wrap x) + (lambda [k] + (k x))) + + (def (M;join mma) + (lambda [k] + (mma (lambda [ma] (ma k)))))) + +## [Functions] +(def #export (call/cc body) + (All [r a b] + (-> (-> (-> a (Cont r b)) (Cont r a)) (Cont r a))) + (lambda [k] + (body k))) diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux deleted file mode 100644 index 63a66d49b..000000000 --- a/source/lux/data/dict.lux +++ /dev/null @@ -1,83 +0,0 @@ -## 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/source/lux/data/id.lux b/source/lux/data/id.lux index 0e3bdbee6..3ad6b056b 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -8,7 +8,8 @@ (;import lux (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) + (monad #as M #refer #all) + (comonad #as CM #refer #all))) ## [Types] (deftype #export (Id a) @@ -23,6 +24,9 @@ (defstruct #export Id/Monad (Monad Id) (def M;_functor Id/Functor) (def (M;wrap a) (#Id a)) - (def (M;join mma) - (let [(#Id ma) mma] - ma))) + (def (M;join mma) (let [(#Id ma) mma] ma))) + +(defstruct #export Id/CoMonad (CoMonad Id) + (def CM;_functor Id/Functor) + (def (CM;unwrap wa) (let [(#Id a) wa] a)) + (def (CM;split wa) (#Id wa))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 8fd5c2951..8d6296b14 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -7,17 +7,66 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all)) - lux/meta/macro) + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (eq #as E) + (dict #as D #refer #all)) + (data/number (int #open ("i" Int/Number Int/Ord Int/Eq))) + meta/macro)) ## Types ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) -## Functions +(deftype #export (PList k v) + (| (#PList (, (E;Eq k) (List (, k v)))))) + +## [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')])))) + +## [Constructors] +(def #export (plist eq) + (All [k v] + (-> (E;Eq k) (PList k v))) + (#PList [eq #;Nil])) + +## [Functions] (def #export (foldL f init xs) (All [a b] (-> (-> a b a) a (List b) a)) @@ -38,6 +87,12 @@ (#;Cons [x xs']) (f x (foldR f init xs')))) +(def #export (fold mon xs) + (All [a] + (-> (m;Monoid a) (List a) a)) + (using mon + (foldL ++ unit xs))) + (def #export (reverse xs) (All [a] (-> (List a) (List a))) @@ -83,8 +138,8 @@ <then>) <else>))] - [take (#;Cons [x (take (dec n) xs')]) #;Nil] - [drop (drop (dec n) xs') xs] + [take (#;Cons [x (take (i+ -1 n) xs')]) #;Nil] + [drop (drop (i+ -1 n) xs') xs] ) (do-template [<name> <then> <else>] @@ -113,7 +168,7 @@ [#;Nil #;Nil] (#;Cons [x xs']) - (let [[tail rest] (split (dec n) xs')] + (let [[tail rest] (split (i+ -1 n) xs')] [(#;Cons [x tail]) rest])) [#;Nil xs])) @@ -139,7 +194,7 @@ (All [a] (-> Int a (List a))) (if (i> n 0) - (#;Cons [x (repeat (dec n) x)]) + (#;Cons [x (repeat (i+ -1 n) x)]) #;Nil)) (def #export (iterate f x) @@ -203,7 +258,7 @@ (#;Cons [x xs']) (if (i= 0 i) (#;Some x) - (@ (dec i) xs')))) + (@ (i+ -1 i) xs')))) ## Syntax (defmacro #export (list xs state) @@ -225,6 +280,17 @@ (#;Left "Wrong syntax for list&"))) ## Structures +## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) +## (def (E;= xs ys) +## (case [xs ys] +## [#;Nil #;Nil] +## true + +## [(#;Cons [x xs']) (#;Cons [y ys'])] +## (and (:: eq (E;= x y)) +## (E;= xs' ys')) +## ))) + (defstruct #export List/Monoid (All [a] (Monoid (List a))) (def m;unit #;Nil) @@ -248,3 +314,16 @@ (def (M;join mma) (using List/Monoid (foldL ++ unit mma)))) + +(defstruct #export PList/Dict (Dict PList) + (def (D;get k plist) + (let [(#PList [eq kvs]) plist] + (pl-get eq k kvs))) + + (def (D;put k v plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-put eq k v kvs)]))) + + (def (D;remove k plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index faec53c2e..396ec470a 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -7,9 +7,12 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) + (.. list) + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) + (meta lux + syntax))) ## [Types] ## (deftype (Maybe a) @@ -40,3 +43,14 @@ (case mma #;None #;None (#;Some xs) xs))) + +## [Syntax] +(defsyntax #export (? maybe else) + (do Lux/Monad + [g!value (gensym "")] + (M;wrap (list (` (case (~ maybe) + (#;Some (~ g!value)) + (~ g!value) + + _ + (~ else))))))) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux new file mode 100644 index 000000000..35c8d34bf --- /dev/null +++ b/source/lux/data/number/int.lux @@ -0,0 +1,89 @@ +## 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 (number #as N) + (monoid #as m) + (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## [Structures] +## Number +(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] + [(defstruct #export <name> (N;Number <type>) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) (</> x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) + (<from> x)) + (def (N;negate x) + (<*> <-1> x)) + (def (N;abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (N;signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [ Int/Number Int _jvm_ladd _jvm_lsub _jvm_lmul _jvm_ldiv _jvm_lrem _jvm_leq _jvm_llt id 0 1 -1]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def (E;= x y) (_jvm_leq x y))) + +## Ord +(do-template [<name> <type> <eq> <=> <lt> <gt>] + [(defstruct #export <name> (O;Ord <type>) + (def O;_eq <eq>) + (def (O;< x y) (<lt> x y)) + (def (O;<= x y) + (or (<lt> x y) + (<=> x y))) + (def (O;> x y) (<gt> x y)) + (def (O;>= x y) + (or (<gt> x y) + (<=> x y))))] + + [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) + +## Bounded +(do-template [<name> <type> <top> <bottom>] + [(defstruct #export <name> (B;Bounded <type>) + (def B;top <top>) + (def B;bottom <bottom>))] + + [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) + +## Monoid +(do-template [<name> <type> <unit> <++>] + [(defstruct #export <name> (m;Monoid <type>) + (def m;unit <unit>) + (def (m;++ x y) (<++> x y)))] + + [ IntAdd/Monoid Int 0 _jvm_ladd] + [ IntMul/Monoid Int 1 _jvm_lmul] + [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + ) + +## Show +(do-template [<name> <type> <body>] + [(defstruct #export <name> (S;Show <type>) + (def (S;show x) + <body>))] + + [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] + ) diff --git a/source/lux/data/number.lux b/source/lux/data/number/real.lux index 8771ef06e..4f9e4fa5f 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number/real.lux @@ -7,75 +7,57 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) - -## Signatures -(defsig #export (Number n) - (do-template [<name>] - [(: (-> n n n) <name>)] - [+] [-] [*] [/] [%]) - - (: (-> Int n) - from-int) - - (do-template [<name>] - [(: (-> n n) <name>)] - [negate] [signum] [abs]) - ) + (lux/control (number #as N) + (monoid #as m) + (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) ## [Structures] ## Number (do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] - [(defstruct #export <name> (Number <type>) - (def + <+>) - (def - <->) - (def * <*>) - (def / </>) - (def % <%>) - (def (from-int x) + [(defstruct #export <name> (N;Number <type>) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) (</> x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) (<from> x)) - (def (negate x) + (def (N;negate x) (<*> <-1> x)) - (def (abs x) + (def (N;abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (signum x) + (def (N;signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else <1>)) )] - [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] - [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) + [Real/Number Real _jvm_dadd _jvm_dsub _jvm_dmul _jvm_ddiv _jvm_drem _jvm_deq _jvm_dlt _jvm_l2d 0.0 1.0 -1.0]) ## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def E;= i=)) - (defstruct #export Real/Eq (E;Eq Real) - (def E;= r=)) + (def (E;= x y) (_jvm_deq x y))) ## Ord -(do-template [<name> <type> <eq> <lt> <gt>] +(do-template [<name> <type> <eq> <=> <lt> <gt>] [(defstruct #export <name> (O;Ord <type>) (def O;_eq <eq>) - (def O;< <lt>) + (def (O;< x y) (<lt> x y)) (def (O;<= x y) (or (<lt> x y) - (:: <eq> (E;= x y)))) - (def O;> <gt>) + (<=> x y))) + (def (O;> x y) (<gt> x y)) (def (O;>= x y) (or (<gt> x y) - (:: <eq> (E;= x y)))))] + (<=> x y))))] - [ Int/Ord Int Int/Eq i< i>] - [Real/Ord Real Real/Eq r< r>]) + [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt]) ## Bounded (do-template [<name> <type> <top> <bottom>] @@ -83,21 +65,16 @@ (def B;top <top>) (def B;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")]) ## Monoid (do-template [<name> <type> <unit> <++>] [(defstruct #export <name> (m;Monoid <type>) (def m;unit <unit>) - (def m;++ <++>))] + (def (m;++ x y) (<++> x y)))] - [ IntAdd/Monoid Int 0 i+] - [ IntMul/Monoid Int 1 i*] - [RealAdd/Monoid Real 0.0 r+] - [RealMul/Monoid Real 1.0 r*] - [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + [RealAdd/Monoid Real 0.0 _jvm_dadd] + [RealMul/Monoid Real 1.0 _jvm_dmul] [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] ) @@ -108,6 +85,5 @@ (def (S;show x) <body>))] - [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] ) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 6ad9cfd63..c3cb1ecfb 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -7,10 +7,11 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (show #as S))) + (lux (control (monoid #as m) + (eq #as E) + (ord #as O) + (show #as S)) + (data/number (int #open ("i" Int/Number Int/Ord Int/Eq))))) ## [Functions] (def #export (size x) diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux new file mode 100644 index 000000000..5220ad4ac --- /dev/null +++ b/source/lux/data/tuple.lux @@ -0,0 +1,39 @@ +## 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) + +## [Functions] +(do-template [<name> <type> <output>] + [(def #export (<name> xy) + (All [a b] (-> (, a b) <type>)) + (let [[x y] xy] + <output>))] + + [first a x] + [second b 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 [xy] + (let [[x y] xy] + (f x y)))) + +(def #export (swap xy) + (All [a b] (-> (, a b) (, b a))) + (let [[x y] xy] + [y x])) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 7af043969..2c90b1ba3 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -11,7 +11,8 @@ (functor #as F) (monad #as M #refer (#only do))) (data (list #as l #refer #all #open ("" List/Functor)) - (text #as text)) + (text #as text) + (number (int #open ("i" Int/Eq)))) (meta lux macro syntax))) @@ -236,3 +237,16 @@ (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ m-classes))] [(~@ m-args)])))))) + +(defsyntax #export (->maybe expr) + (do Lux/Monad + [g!val (gensym "")] + (emit (list (` (;let [(~ g!val) (~ expr)] + (;if (null? (~ g!val)) + #;None + (#;Some (~ g!val))))))))) + +(defsyntax #export (try$ expr) + (emit (list (` (try (#;Right (~ expr)) + (~ (' (catch java.lang.Exception e + (#;Left (.! (getMessage [] []) e)))))))))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 19b7dd9df..13dcae284 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -10,12 +10,11 @@ (.. macro) (lux/control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) + (monad #as M #refer (#only do)) + (show #as S)) (lux/data list - maybe - (show #as S) - (number #as N) - (text #as T #open ("text:" Text/Monoid Text/Eq)))) + (text #as T #open ("text:" Text/Monoid Text/Eq)) + (number/int #as I #open ("i" Int/Number)))) ## [Types] ## (deftype (Lux a) @@ -77,20 +76,27 @@ (def (find-macro' modules current-module module name) (-> (List (, Text (Module Compiler))) Text Text Text (Maybe Macro)) - (do 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') + (case (get module modules) + (#;Some $module) + (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) + (#;Some gdef) + (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) - - [_ (#;AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) _ - #;None))) + #;None) + + _ + #;None)) (def #export (find-macro ident) (-> Ident (Lux (Maybe Macro))) @@ -147,8 +153,8 @@ (def #export (gensym prefix state) (-> Text (Lux Syntax)) - (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) + (#;Right [(update@ #;seed (i+ 1) state) + (symbol$ ["__gensym__" (:: I;Int/Show (S;show (get@ #;seed state)))])])) (def #export (emit datum) (All [a] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 63ab81475..972999fcb 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -10,12 +10,14 @@ (.. (macro #as m #refer #all) (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) - (monad #as M #refer (#only do))) - (data (eq #as E) - (bool #as b) + (monad #as M #refer (#only do)) + (eq #as E)) + (data (bool #as b) (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) - list))) + list + (number (int #open ("i" Int/Eq)) + (real #open ("r" Real/Eq)))))) ## [Utils] (def (first xy) diff --git a/source/program.lux b/source/program.lux index 086506725..b9f737480 100644 --- a/source/program.lux +++ b/source/program.lux @@ -7,31 +7,34 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (codata (stream #as S)) - (control monoid + (lux (control monoid functor monad - lazy - comonad) + comonad + bounded + dict + eq + ord + show + number) (data bool - bounded char - ## cont - dict (either #as e) - eq error id io list maybe - number - ord - (reader #as r) - show - state + (number int + real) (text #as t #open ("text:" Text/Monoid)) - writer) + writer + tuple) + (codata (stream #as S) + lazy + function + (reader #as r) + state) (host jvm) (meta lux macro diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 3449900e0..b88bb9c0a 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -29,7 +29,8 @@ [host :as &&host] [case :as &&case] [lambda :as &&lambda] - [package :as &&package])) + [package :as &&package] + [io :as &&io])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -372,54 +373,55 @@ (defn ^:private compile-module [name] ;; (prn 'compile-module name (&&cache/cached? name)) - (let [file-name (str &&/input-dir "/" name ".lux") - file-content (slurp file-name) - file-hash (hash file-content)] - (if (&&cache/cached? name) - (&&cache/load name file-hash compile-module) - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) - :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd)) - ;; _ (prn 'compile-module name =class) - ]] - (fn [state] - (matchv ::M/objects [((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] - [["lux;Right" [?state _]]] - (&/run-state (|do [defs &a-module/defs - imports &a-module/imports - :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) - .visitEnd) - (.visitEnd)) - ;; _ (prn 'CLOSED name =class) - ]] - (&&/save-class! "_" (.toByteArray =class))) - ?state) - - [["lux;Left" ?message]] - (fail* ?message))))))) - ))) + (let [file-name (str &&/input-dir "/" name ".lux")] + (|do [file-content (&&io/read-file file-name) + :let [file-hash (hash file-content)]] + (if (&&cache/cached? name) + (&&cache/load name file-hash compile-module) + (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] + (&/map% compile-statement analysis+))] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&a-module/enter-module name) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + .visitEnd)) + ;; _ (prn 'compile-module name =class) + ]] + (fn [state] + (matchv ::M/objects [((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] + [["lux;Right" [?state _]]] + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose "\t") (&/fold str ""))) + .visitEnd) + (.visitEnd)) + ;; _ (prn 'CLOSED name =class) + ]] + (&&/save-class! "_" (.toByteArray =class))) + ?state) + + [["lux;Left" ?message]] + (fail* ?message))))))) + )) + )) (defn ^:private init! [] (.mkdirs (java.io.File. &&/output-dir))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index c0d978146..45513d0a5 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -17,7 +17,8 @@ [host :as &host]) (lux.analyser [base :as &a] [module :as &a-module]) - (lux.compiler [base :as &&])) + (lux.compiler [base :as &&] + [io :as &&io])) (:import (java.io File BufferedOutputStream FileOutputStream) @@ -74,65 +75,66 @@ (return false))]] (do ;; (prn 'load module 'sources already-loaded? ;; (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str &&/output-dir "/" module*) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= &&/version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - ;; _ (prn 'load/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - ;; (prn 'load module defs) - (|do [_ (&a-module/enter-module module) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) - "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) + (if already-loaded? + (return true) + (if (cached? module) + (do ;; (prn 'load/HASH module module-hash) + (let [module* (&host/->module-class module) + module-path (str &&/output-dir "/" module*) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= &&/version (get-field "_compiler" module-meta))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + ;; _ (prn 'load/IMPORTS module imports) + ] + (|do [loads (&/map% (fn [_import] + (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux"))] + (load _import (hash content) compile-module))) + (if (= [""] imports) (&/|list) - (&/->list defs)))] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file) + ;; _ (prn 'load module real-name) + ] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + ;; (prn 'load module defs) + (|do [_ (&a-module/enter-module module) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + ] + (|do [_ (case _ann + "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] + (&a-module/declare-macro module _name)) + "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) + def-type (get-field "_meta" def-class)] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module _name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module _name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs)))] + (return true)))) + redo-cache))) + redo-cache) + )) + redo-cache))))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 346b66fd2..542bd9a40 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -88,11 +88,11 @@ (defn <name> [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) @@ -191,9 +191,9 @@ 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 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" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()D" ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj new file mode 100644 index 000000000..176b4340d --- /dev/null +++ b/src/lux/compiler/io.clj @@ -0,0 +1,18 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.io + (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) + )) + +;; [Resources] +(defn read-file [path] + (let [file (new java.io.File path)] + (if (.exists file) + (return (slurp file)) + (fail (str "[I/O] File doesn't exist: " path))))) |