From 7f39dd6a229b3b5a8e8d4108ecd1f5307b3cbf06 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 6 May 2015 23:44:24 -0400 Subject: - Made several optimizations to the compiler. - Also removed several unused definitions. --- source/lux.lux | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index acaee2265..5b59d788f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -237,7 +237,7 @@ (export' LuxVar) ## (deftype #rec CompilerState -## (& #source (Maybe Reader) +## (& #source Reader ## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))) ## #module-aliases (List Void) ## #envs (List (Env Text (, LuxVar Type))) @@ -245,7 +245,7 @@ ## #host HostState)) (def' CompilerState (#AppT [(#AllT [#None "CompilerState" "" - (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] + (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList -- cgit v1.2.3 From 0d365358ebc7d3e6f99c74641162d2024772698c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 7 May 2015 00:19:31 -0400 Subject: - Eliminated #eval-ctor from the HostState and now #seed is used for the same purpose. - Optimized some code a bit. --- source/lux.lux | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 5b59d788f..d2a309b5f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -206,13 +206,11 @@ ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #eval-ctor Int)) +## #loader (^ java.net.URLClassLoader))) (def' HostState (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;eval-ctor" Int] - #Nil])])]))) + #Nil])]))) ## (deftype (DefData' m) ## (| #TypeD -- cgit v1.2.3 From ab7b946a980475cad1e58186ac8c929c7659f529 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 10 May 2015 10:37:06 -0400 Subject: - Now analysing function-application backwards. --- source/lux.lux | 682 ++++++++++++++++++++++++----------------------------- source/program.lux | 6 +- 2 files changed, 311 insertions(+), 377 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index d2a309b5f..26425e7b8 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -351,10 +351,9 @@ (lambda' _ tokens (case' tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [($form (#Cons [($symbol ["" "case'"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil]))) + (return (#Cons [($form (#Cons [($symbol ["" "case'"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) _ (fail "Wrong syntax for let'"))))) @@ -365,36 +364,34 @@ (lambda' _ tokens (case' tokens (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol ["" ""])) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) + (#Cons [(_meta (#Symbol ["" ""])) + (#Cons [arg + (#Cons [(case' args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol self)) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) + (#Cons [(_meta (#Symbol self)) + (#Cons [arg + (#Cons [(case' args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) _ (fail "Wrong syntax for lambda"))))) @@ -403,118 +400,110 @@ (def' def_ (:' Macro (lambda_ [tokens] - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])]))) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])]))) - - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil]))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil]))) + (case' tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) - _ - (fail "Wrong syntax for def") - )))) + _ + (fail "Wrong syntax for def") + )))) (declare-macro' def_) (def_ #export (defmacro tokens) Macro (case' tokens (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])]))) + (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) + #Nil])])) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#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 ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])]))) + (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 ["" "declare-macro'"]) (#Cons [name #Nil])])) + #Nil])])) _ (fail "Wrong syntax for defmacro"))) (declare-macro' defmacro) (defmacro #export (comment tokens) - (return (:' SyntaxList #Nil))) + (return #Nil)) (defmacro (->' tokens) (case' tokens (#Cons [input (#Cons [output #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) (#Cons [input (#Cons [output others])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for ->'"))) @@ -523,24 +512,22 @@ (case' tokens (#Cons [(#Meta [_ (#Tuple #Nil)]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [body - #Nil]))) + (return (#Cons [body + #Nil])) (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) - (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) - (#Cons [(_meta (#Text "")) - (#Cons [(_meta (#Text arg-name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) - (#Cons [(_meta (#Tuple other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) + (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) + (#Cons [(_meta (#Text "")) + (#Cons [(_meta (#Text arg-name)) + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) + (#Cons [(_meta (#Tuple other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for All'"))) @@ -549,11 +536,10 @@ (case' tokens (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) #Nil]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) - (#Cons [(_meta (#Text bound-name)) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) + (#Cons [(_meta (#Text bound-name)) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for B'"))) @@ -564,13 +550,12 @@ (return tokens) (#Cons [x (#Cons [y xs])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) - (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) + (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) + (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) _ (fail "Wrong syntax for $'"))) @@ -591,34 +576,27 @@ (def_ #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (fold (:' (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda_ [tail head] - (#Cons [head tail]))) + (fold (lambda_ [tail head] (#Cons [head tail])) #Nil list)) (defmacro #export (list xs) - (return (:' SyntaxList - (#Cons [(fold (:' (->' Syntax Syntax Syntax) - (lambda_ [tail head] - (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) - (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) - #Nil])]))))) - (_meta (#Tag ["lux" "Nil"])) - (reverse xs)) - #Nil])))) + (return (#Cons [(fold (lambda_ [tail head] + (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) + (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#Tag ["lux" "Nil"])) + (reverse xs)) + #Nil]))) (defmacro #export (list& xs) (case' (reverse xs) (#Cons [last init]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda_ [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list head tail)))))))) - last - init)))) + (return (list (fold (lambda_ [tail head] + (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) + (_meta (#Tuple (list head tail))))))) + last + init))) _ (fail "Wrong syntax for list&"))) @@ -638,19 +616,16 @@ (fail "lambda requires a non-empty arguments tuple.") (#Cons [harg targs]) - (let' body' (fold (:' (->' Syntax Syntax Syntax) - (lambda_ [body' arg] - ($form (list ($symbol ["" "lambda'"]) - ($symbol ["" ""]) - arg - body')))) - body - (reverse targs)) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "lambda'"]) - ($symbol name) - harg - body'))))))) + (return (list ($form (list ($symbol ["" "lambda'"]) + ($symbol name) + harg + (fold (lambda_ [body' arg] + ($form (list ($symbol ["" "lambda'"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs))))))) _ (fail "Wrong syntax for lambda")))) @@ -660,43 +635,39 @@ (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "export'"]) name))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "export'"]) name)))) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - body)))) - ($form (list ($symbol ["" "export'"]) name))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) + type + body)))) + ($form (list ($symbol ["" "export'"]) name)))) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body))))))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) type body))))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) type body)))))) _ (fail "Wrong syntax for def") @@ -715,20 +686,19 @@ (defmacro #export (let tokens) (case' tokens (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (case' binding - [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) - body - (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) - ($' List (#TupleT (list Syntax Syntax)))) - (lambda [tail head] - (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) + (return (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (case' binding + [label value] + (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) + body + (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) + ($' List (#TupleT (list Syntax Syntax)))) + (lambda [tail head] + (#Cons [head tail]))) + #Nil + (as-pairs bindings))))) _ (fail "Wrong syntax for let"))) @@ -792,12 +762,9 @@ (defmacro #export ($ tokens) (case' tokens (#Cons [op (#Cons [init args])]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [a1 a2] - ($form (list op a1 a2)))) - init - args)))) + (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) + init + args))) _ (fail "Wrong syntax for $"))) @@ -882,8 +849,7 @@ (defmacro (`' tokens) (case' tokens (#Cons [template #Nil]) - (return (:' SyntaxList - (list (untemplate "" template)))) + (return (list (untemplate "" template))) _ (fail "Wrong syntax for `'"))) @@ -891,17 +857,15 @@ (defmacro #export (|> tokens) (case' tokens (#Cons [init apps]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [acc app] - (case' app - (#Meta [_ (#Form parts)]) - ($form (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) + (return (list (fold (lambda [acc app] + (case' app + (#Meta [_ (#Form parts)]) + ($form (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc))))) + init + apps))) _ (fail "Wrong syntax for |>"))) @@ -909,10 +873,9 @@ (defmacro #export (if tokens) (case' tokens (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (:' SyntaxList - (list (`' (case' (~ test) - true (~ then) - false (~ else)))))) + (return (list (`' (case' (~ test) + true (~ then) + false (~ else))))) _ (fail "Wrong syntax for if"))) @@ -969,8 +932,7 @@ (defmacro #export (^ tokens) (case' tokens (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) - (return (:' SyntaxList - (list (`' (#;DataT (~ (_meta (#Text class-name)))))))) + (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) _ (fail "Wrong syntax for ^"))) @@ -978,19 +940,15 @@ (defmacro #export (-> tokens) (case' (reverse tokens) (#Cons [output inputs]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [o i] - (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) + (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) _ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (:' SyntaxList - (list (`' (#;TupleT (;list (~@ tokens)))))))) + (return (list (`' (#;TupleT (;list (~@ tokens))))))) (defmacro (do tokens) (case' tokens @@ -1004,15 +962,14 @@ _ (`' (;bind (lambda' (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] - (return (:' SyntaxList - (list (`' (case' (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))))) + (return (list (`' (case' (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) _ (fail "Wrong syntax for do"))) @@ -1028,13 +985,13 @@ (let [{#;return ;return #;bind _} m] (case' xs #Nil - (;return (:' List #Nil)) + (;return #Nil) (#Cons [x xs']) (do m [y (f x) ys (map% m f xs')] - (;return (:' List (#Cons [y ys])))) + (;return (#Cons [y ys]))) ))) (def__ #export (. f g) @@ -1241,19 +1198,16 @@ (#Some idents) (case' idents #Nil - (return (:' SyntaxList (list body))) + (return (list body)) (#Cons [harg targs]) (let [replacements (map (:' (-> Text (, Text Syntax)) (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) (list& self-ident idents)) - body' (fold (:' (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + body' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) (replace-syntax replacements body) (reverse targs))] - (return (:' SyntaxList - (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) #None (fail "'All' arguments must be symbols.")) @@ -1313,13 +1267,12 @@ (do Lux:Monad [current-module get-module-name] (let [[module name] ident] - (:' ($' Lux ($' Maybe Macro)) - (lambda [state] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (#Right [state (find-macro' modules current-module module name)]))))))) + (lambda [state] + (case' state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (#Right [state (find-macro' modules current-module module name)])))))) (def__ (list:join xs) (All [a] @@ -1353,17 +1306,17 @@ (#Meta [_ (#Tag ident)]) (do Lux:Monad [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + (;return (`' [(~ ($text (ident->text ident))) (;,)]))) (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) (do Lux:Monad [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for |")))) tokens)] - (;return (:' SyntaxList (list (`' (#;VariantT (;list (~@ pairs))))))))) + (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1376,12 +1329,12 @@ [(#Meta [_ (#Tag ident)]) value] (do Lux:Monad [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (:' SyntaxList (list (`' (#;RecordT (;list (~@ pairs)))))))))) + (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) (def__ #export (->text x) (-> (^ java.lang.Object) Text) @@ -1446,31 +1399,31 @@ (do Lux:Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] - (case' (:' ($' Maybe Macro) ?macro) + (case' ?macro (#Some macro) (do Lux:Monad [expansion (macro args) expansion' (map% Lux:Monad macro-expand expansion)] - (;return (:' SyntaxList (list:join expansion')))) + (;return (list:join expansion'))) #None (do Lux:Monad [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (:' SyntaxList (list ($form (list:join parts')))))))) + (;return (list ($form (list:join parts'))))))) (#Meta [_ (#Form (#Cons [harg targs]))]) (do Lux:Monad [harg+ (macro-expand harg) targs+ (map% Lux:Monad macro-expand targs)] - (;return (:' SyntaxList (list ($form (list:++ harg+ (list:join (:' ($' List ($' List Syntax)) targs+)))))))) + (;return (list ($form (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#Tuple members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] - (;return (:' SyntaxList (list ($tuple (list:join members')))))) + (;return (list ($tuple (list:join members'))))) _ - (return (:' SyntaxList (list syntax))))) + (return (list syntax)))) (def__ (walk-type type) (-> Syntax Syntax) @@ -1482,9 +1435,7 @@ ($tuple (map walk-type members)) (#Meta [_ (#Form (#Cons [type-fn args]))]) - (fold (:' (-> Syntax Syntax Syntax) - (lambda [type-fn arg] - (`' (#;AppT [(~ type-fn) (~ arg)])))) + (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1496,9 +1447,9 @@ (#Cons [type #Nil]) (do Lux:Monad [type+ (macro-expand type)] - (case' (:' SyntaxList type+) + (case' type+ (#Cons [type' #Nil]) - (;return (:' SyntaxList (list (walk-type type')))) + (;return (list (walk-type type'))) _ (fail "type`: The expansion of the type-syntax had to yield a single element."))) @@ -1509,7 +1460,7 @@ (defmacro #export (: tokens) (case' tokens (#Cons [type (#Cons [value #Nil])]) - (return (:' SyntaxList (list (`' (:' (;type` (~ type)) (~ value)))))) + (return (list (`' (:' (;type` (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) @@ -1517,7 +1468,7 @@ (defmacro #export (:! tokens) (case' tokens (#Cons [type (#Cons [value #Nil])]) - (return (:' SyntaxList (list (`' (:!' (;type` (~ type)) (~ value)))))) + (return (list (`' (:!' (;type` (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) @@ -1539,9 +1490,7 @@ (#Some [($symbol name) args type]) _ - #None)) - ] - ## (return (: (List Syntax) #Nil)) + #None))] (case' parts (#Some [name args type]) (let [with-export (: (List Syntax) @@ -1555,9 +1504,8 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (;type` (~ type')))) - with-export)))) + (return (list& (`' (def' (~ name) (;type` (~ type')))) + with-export))) #None (fail "Wrong syntax for deftype")) @@ -1570,8 +1518,7 @@ (case' tokens (#Cons [value #Nil]) (let [blank ($symbol ["" ""])] - (return (: (List Syntax) - (list (`' (lambda' (~ blank) (~ blank) (~ value))))))) + (return (list (`' (lambda' (~ blank) (~ blank) (~ value)))))) _ (fail "Wrong syntax for io"))) @@ -1580,12 +1527,9 @@ (case' (reverse tokens) (#Cons [value actions]) (let [dummy ($symbol ["" ""])] - (return (:' SyntaxList - (list (fold (:' (-> Syntax Syntax Syntax) - (lambda [post pre] - (`' (case' (~ pre) (~ dummy) (~ post))))) - value - actions))))) + (return (list (fold (lambda [post pre] (`' (case' (~ pre) (~ dummy) (~ post)))) + value + actions)))) _ (fail "Wrong syntax for exec"))) @@ -1630,10 +1574,10 @@ #None body'))] - (return (: (List Syntax) (list& (`' (def' (~ name) (~ body''))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + (return (list& (`' (def' (~ name) (~ body''))) + (if export? + (list (`' (export' (~ name)))) + #Nil)))) #None (fail "Wrong syntax for def")))) @@ -1655,16 +1599,14 @@ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol 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 (: (List Syntax) expansion)))] - (;return (list:join (: (List (List (, Syntax Syntax))) expansions)))) + expansions (map% Lux:Monad expander (as-pairs expansion))] + (;return (list:join expansions))) _ - (;return (: (List (, Syntax Syntax)) (list branch))))))) + (;return (list branch)))))) (as-pairs branches))] - (;return (: (List Syntax) - (list (`' (case' (~ value) - (~@ (|> (: (List (List (, Syntax Syntax))) expansions) list:join (map rejoin-pair) list:join)) - )))))) + (;return (list (`' (case' (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) _ (fail "Wrong syntax for case"))) @@ -1674,9 +1616,9 @@ (#Cons [body (#Cons [pattern #Nil])]) (do Lux:Monad [pattern+ (macro-expand pattern)] - (case (: (List Syntax) pattern+) + (case pattern+ (#Cons [pattern' #Nil]) - (;return (: (List Syntax) (list pattern' body))) + (;return (list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1694,10 +1636,8 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (: (List Syntax) (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] - (list pattern body))) - (list:join (: (List (List Syntax)) patterns')))))))) + (;return (list:join (map (lambda [pattern] (list pattern body)) + (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) @@ -1718,8 +1658,7 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (: (List Syntax) - (list (untemplate (: Text module-name) template)))) + (;return (list (untemplate module-name template))) _ (fail "Wrong syntax for `")))) @@ -1739,7 +1678,7 @@ (-> Syntax (Lux Syntax)) (do Lux:Monad [token+ (macro-expand token)] - (case (: (List Syntax) token+) + (case token+ (\ (list token')) (;return token') @@ -1760,14 +1699,13 @@ _ (fail "Signatures require typed members!")))) - (: (List Syntax) tokens'))] - (;return (: (List Syntax) - (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - (: (List (, Ident Syntax)) members))))))))))) + tokens')] + (;return (list (`' (#;RecordT (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)) @@ -1789,17 +1727,17 @@ #None))] (case ?parts (#Some [name args sigs]) - (let [sigs' (: Syntax (case args - #Nil - (`' (;sig (~@ sigs))) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (~ sigs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + _ + (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (`' (def' (~ name) (~ sigs'))) + (if export? + (list (`' (export' (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) @@ -1818,9 +1756,8 @@ _ (fail "Structures require defined members!")))) - (: (List Syntax) tokens'))] - (;return (: (List Syntax) - (list ($record members)))))) + tokens')] + (;return (list ($record members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1842,17 +1779,17 @@ #None))] (case ?parts (#Some [name args type defs]) - (let [defs' (: Syntax (case args - #Nil - (`' (;struct (~@ defs))) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (: (List Syntax) - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (export' (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) @@ -1901,11 +1838,9 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (: (List Syntax) - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] (`
))) - last - init)))) + (return (list (fold (lambda [post pre] (` )) + last + init))) _ (fail )))] @@ -1944,10 +1879,9 @@ (list name) (list))))) lux)] - (#Right [state (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name])) - (~ ($symbol ["lux" name])))))) + (#Right [state (map (lambda [name] + (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name])) + (~ ($symbol ["lux" name]))))) (list:join to-alias))])) #None diff --git a/source/program.lux b/source/program.lux index 22bbad2d5..2bbf3fd4f 100644 --- a/source/program.lux +++ b/source/program.lux @@ -13,6 +13,6 @@ (jvm-program _ (exec (println "Hello, world!") - (println ($ text:++ "2 + 2 = " (->text (int:+ 2 2)))) - (println (->text (using Int:Ord - (< 5 10)))))) + (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) + (println (->text (using Int:Ord + (< 5 10)))))) -- cgit v1.2.3 From 8dc736e2a383fe964d63dda6b885d41cabc6261c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 10 May 2015 15:04:36 -0400 Subject: - Switched to the new prefix convention for both lux's special forms and the host's. - Made a few optimizations to speed-up the now slowed-down compiler. --- source/lux.lux | 2317 ++++++++++++++++++++++++++-------------------------- source/program.lux | 10 +- 2 files changed, 1169 insertions(+), 1158 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 26425e7b8..f2a6f70da 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -7,53 +7,53 @@ ## You must not remove this notice, or any other, from this software. ## First things first, must define functions -(jvm-interface Function - (:' (-> [java.lang.Object] java.lang.Object) +(_jvm_interface Function + (: (-> [java.lang.Object] java.lang.Object) apply)) ## Basic types -(def' Bool (#DataT "java.lang.Boolean")) -(export' Bool) +(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_export Bool) -(def' Int (#DataT "java.lang.Long")) -(export' Int) +(_lux_def Int (#DataT "java.lang.Long")) +(_lux_export Int) -(def' Real (#DataT "java.lang.Double")) -(export' Real) +(_lux_def Real (#DataT "java.lang.Double")) +(_lux_export Real) -(def' Char (#DataT "java.lang.Character")) -(export' Char) +(_lux_def Char (#DataT "java.lang.Character")) +(_lux_export Char) -(def' Text (#DataT "java.lang.String")) -(export' Text) +(_lux_def Text (#DataT "java.lang.String")) +(_lux_export Text) -(def' Void (#VariantT #Nil)) -(export' Void) +(_lux_def Void (#VariantT #Nil)) +(_lux_export Void) -(def' Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) -(export' Ident) +(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) -(def' List - (#AllT [#None "List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) -(export' List) +(_lux_def List + (#AllT [#None "List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) +(_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) -(def' Maybe - (#AllT [#None "Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) -(export' Maybe) +(_lux_def Maybe + (#AllT [#None "Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) +(_lux_export Maybe) ## (deftype #rec Type ## (| (#DataT Text) @@ -65,70 +65,70 @@ ## (#VarT Int) ## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) ## (#AppT (, Type Type)))) -(def' Type - (case' (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (case' (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [#None "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) -(export' Type) +(_lux_def Type + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [#None "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) +(_lux_export Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) -(def' Bindings - (#AllT [#None "Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) +(_lux_def Bindings + (#AllT [#None "Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) ## (deftype (Env k v) ## (& #name Text ## #inner-closures Int ## #locals (Bindings k v) ## #closure (Bindings k v))) -(def' Env - (#AllT [#None "Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) +(_lux_def Env + (#AllT [#None "Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) ## (deftype Cursor ## (, Text Int Int)) -(def' Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_def Cursor + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) -(def' Meta - (#AllT [#None "Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) -(export' Meta) +(_lux_def Meta + (#AllT [#None "Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) +(_lux_export Meta) ## (deftype (Syntax' w) ## (| (#Bool Bool) @@ -141,98 +141,98 @@ ## (#Form (List (w (Syntax' w)))) ## (#Tuple (List (w (Syntax' w)))) ## (#Record (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(def' Syntax' - (case' (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") - (#BoundT "w")])]) - Syntax - (case' (#AppT [List Syntax]) - SyntaxList - (#AllT [#None "Syntax'" "w" - (#VariantT (#Cons [["lux;Bool" Bool] - (#Cons [["lux;Int" Int] - (#Cons [["lux;Real" Real] - (#Cons [["lux;Char" Char] - (#Cons [["lux;Text" Text] - (#Cons [["lux;Symbol" Ident] - (#Cons [["lux;Tag" Ident] - (#Cons [["lux;Form" SyntaxList] - (#Cons [["lux;Tuple" SyntaxList] - (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(export' Syntax') +(_lux_def Syntax' + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [#None "Syntax'" "w" + (#VariantT (#Cons [["lux;Bool" Bool] + (#Cons [["lux;Int" Int] + (#Cons [["lux;Real" Real] + (#Cons [["lux;Char" Char] + (#Cons [["lux;Text" Text] + (#Cons [["lux;Symbol" Ident] + (#Cons [["lux;Tag" Ident] + (#Cons [["lux;Form" SyntaxList] + (#Cons [["lux;Tuple" SyntaxList] + (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) +(_lux_export Syntax') ## (deftype Syntax ## (Meta Cursor (Syntax' (Meta Cursor)))) -(def' Syntax - (case' (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(export' Syntax) +(_lux_def Syntax + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) +(_lux_export Syntax) -(def' SyntaxList (#AppT [List Syntax])) +(_lux_def SyntaxList (#AppT [List Syntax])) ## (deftype (Either l r) ## (| (#Left l) ## (#Right r))) -(def' Either - (#AllT [#None "_" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) -(export' Either) +(_lux_def Either + (#AllT [#None "_" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) +(_lux_export Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) -(def' StateE - (#AllT [#None "StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) - -## (def' Reader +(_lux_def StateE + (#AllT [#None "StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) + +## (deftype Reader ## (List (Meta Cursor Text))) -(def' Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) -(export' Reader) +(_lux_def Reader + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) +(_lux_export Reader) ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader))) -(def' HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - #Nil])]))) +(_lux_def HostState + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + #Nil])]))) ## (deftype (DefData' m) ## (| #TypeD ## (#ValueD Type) ## (#MacroD m) ## (#AliasD Ident))) -(def' DefData' - (#AllT [#None "DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) +(_lux_def DefData' + (#AllT [#None "DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) ## (deftype LuxVar ## (| (#Local Int) ## (#Global Ident))) -(def' LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) -(export' LuxVar) +(_lux_def LuxVar + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) +(_lux_export LuxVar) ## (deftype #rec CompilerState ## (& #source Reader @@ -241,324 +241,324 @@ ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) -(def' CompilerState - (#AppT [(#AllT [#None "CompilerState" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") - (#BoundT "")])]) - SyntaxList])])]) - #Nil])])) - #Nil])]))]) - #Nil])]))])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - #Nil])])])])])])]))]) - Void])) -(export' CompilerState) +(_lux_def CompilerState + (#AppT [(#AllT [#None "CompilerState" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") + (#BoundT "")])]) + SyntaxList])])]) + #Nil])])) + #Nil])]))]) + #Nil])]))])] + (#Cons [["lux;module-aliases" (#AppT [List Void])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + #Nil])])])])])])]))]) + Void])) +(_lux_export CompilerState) ## (deftype Macro ## (-> (List Syntax) (StateE CompilerState (List Syntax)))) -(def' Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) - SyntaxList])])) -(export' Macro) +(_lux_def Macro + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE CompilerState]) + SyntaxList])])) +(_lux_export Macro) ## Base functions & macros ## (def (_meta data) ## (-> (Syntax' (Meta Cursor)) Syntax) ## (#Meta [["" -1 -1] data])) -(def' _meta - (:' (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (lambda' _ data - (#Meta [["" -1 -1] data])))) +(_lux_def _meta + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [["" -1 -1] data])))) ## (def (return x) ## (All [a] ## (-> a CompilerState ## (Either Text (, CompilerState a)))) ## ...) -(def' return - (:' (#AllT [#None "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (lambda' _ val - (lambda' _ state - (#Right [state val]))))) +(_lux_def return + (_lux_: (#AllT [#None "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) ## (def (fail msg) ## (All [a] ## (-> Text CompilerState ## (Either Text (, CompilerState a)))) ## ...) -(def' fail - (:' (#AllT [#None "" "a" - (#LambdaT [Text - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (lambda' _ msg - (lambda' _ state - (#Left msg))))) - -(def' $text - (:' (#LambdaT [Text Syntax]) - (lambda' _ text - (_meta (#Text text))))) - -(def' $symbol - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Symbol ident))))) - -(def' $tag - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Tag ident))))) - -(def' $form - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Form tokens))))) - -(def' $tuple - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Tuple tokens))))) - -(def' $record - (:' (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (lambda' _ tokens - (_meta (#Record tokens))))) - -(def' let' - (:' Macro - (lambda' _ tokens - (case' tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["" "case'"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil])) - - _ - (fail "Wrong syntax for let'"))))) -(declare-macro' let') - -(def' lambda_ - (:' Macro - (lambda' _ tokens - (case' tokens - (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol ["" ""])) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol self)) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - _ - (fail "Wrong syntax for lambda"))))) -(declare-macro' lambda_) - -(def' def_ - (:' Macro - (lambda_ [tokens] - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) - - _ - (fail "Wrong syntax for def") - )))) -(declare-macro' def_) +(_lux_def fail + (_lux_: (#AllT [#None "" "a" + (#LambdaT [Text + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) + +(_lux_def $text + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#Text text))))) + +(_lux_def $symbol + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#Symbol ident))))) + +(_lux_def $tag + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#Tag ident))))) + +(_lux_def $form + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#Form tokens))))) + +(_lux_def $tuple + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#Tuple tokens))))) + +(_lux_def $record + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#Record tokens))))) + +(_lux_def let' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) + + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') + +(_lux_def lambda_ + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) + (#Cons [(_meta (#Symbol ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) + (#Cons [(_meta (#Symbol self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + _ + (fail "Wrong syntax for lambda"))))) +(_lux_declare-macro lambda_) + +(_lux_def def_ + (_lux_: Macro + (lambda_ [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) + + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def_) (def_ #export (defmacro tokens) Macro - (case' tokens - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])])) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#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"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro"))) -(declare-macro' defmacro) + (_lux_case tokens + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (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])])) + #Nil])])) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#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"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) (defmacro #export (comment tokens) (return #Nil)) (defmacro (->' tokens) - (case' tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for ->'"))) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) + + (#Cons [input (#Cons [output others])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for ->'"))) (defmacro (All' tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) - (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) - (#Cons [(_meta (#Text "")) - (#Cons [(_meta (#Text arg-name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) - (#Cons [(_meta (#Tuple other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for All'"))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple #Nil)]) + (#Cons [body #Nil])]) + (return (#Cons [body + #Nil])) + + (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) + (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) + (#Cons [(_meta (#Text "")) + (#Cons [(_meta (#Text arg-name)) + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) + (#Cons [(_meta (#Tuple other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for All'"))) (defmacro (B' tokens) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) - (#Cons [(_meta (#Text bound-name)) - #Nil])]))) - #Nil])) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) + #Nil]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) + (#Cons [(_meta (#Text bound-name)) + #Nil])]))) + #Nil])) - _ - (fail "Wrong syntax for B'"))) + _ + (fail "Wrong syntax for B'"))) (defmacro ($' tokens) - (case' tokens - (#Cons [x #Nil]) - (return tokens) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) - (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) + (#Cons [x (#Cons [y xs])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) + (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) + (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) - _ - (fail "Wrong syntax for $'"))) + _ + (fail "Wrong syntax for $'"))) (def_ #export (fold f init xs) (All' [a b] @@ -566,12 +566,12 @@ (B' a) ($' List (B' b)) (B' a))) - (case' xs - #Nil - init + (_lux_case xs + #Nil + init - (#Cons [x xs']) - (fold f (f init x) xs'))) + (#Cons [x xs']) + (fold f (f init x) xs'))) (def_ #export (reverse list) (All' [a] @@ -590,149 +590,146 @@ #Nil]))) (defmacro #export (list& xs) - (case' (reverse xs) - (#Cons [last init]) - (return (list (fold (lambda_ [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list head tail))))))) - last - init))) + (_lux_case (reverse xs) + (#Cons [last init]) + (return (list (fold (lambda_ [tail head] + (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) + (_meta (#Tuple (list head tail))))))) + last + init))) - _ - (fail "Wrong syntax for list&"))) + _ + (fail "Wrong syntax for list&"))) (defmacro #export (lambda tokens) - (let' [name tokens'] (:' (#TupleT (list Ident ($' List Syntax))) - (case' tokens - (#Cons [(#Meta [_ (#Symbol name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (case' tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) - (case' args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list ($form (list ($symbol ["" "lambda'"]) - ($symbol name) - harg - (fold (lambda_ [body' arg] - ($form (list ($symbol ["" "lambda'"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs))))))) + (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol name)]) tokens']) + [name tokens'] - _ - (fail "Wrong syntax for lambda")))) + _ + [["" ""] tokens])) + (_lux_case tokens' + (#Cons [(#Meta [_ (#Tuple 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 + (fold (lambda_ [body' arg] + ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda")))) (defmacro (def__ tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "export'"]) name)))) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - body)))) - ($form (list ($symbol ["" "export'"]) name)))) - - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) type body)))))) - - _ - (fail "Wrong syntax for def") - )) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + body)))) + ($form (list ($symbol ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) type body)))))) + + _ + (fail "Wrong syntax for def") + )) (def__ (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) - (case' xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (_lux_case xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) - _ - #Nil)) + _ + #Nil)) (defmacro #export (let tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) - (return (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (case' binding - [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) - body - (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) - ($' List (#TupleT (list Syntax Syntax)))) - (lambda [tail head] - (#Cons [head tail]))) - #Nil - (as-pairs bindings))))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) + (return (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) + body + (fold (lambda [tail head] (#Cons [head tail])) + #Nil + (as-pairs bindings))))) - _ - (fail "Wrong syntax for let"))) + _ + (fail "Wrong syntax for let"))) (def__ #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (case' xs - #Nil - #Nil + (_lux_case xs + #Nil + #Nil - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) (def__ #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) - (case' xs - #Nil - false + (_lux_case xs + #Nil + false - (#Cons [x xs']) - (case' (p x) - true true - false (any? p xs')))) + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) (def__ (spliced? token) (->' Syntax Bool) - (case' token - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) - true + (_lux_case token + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) + true - _ - false)) + _ + false)) (def__ (wrap-meta content) (->' Syntax Syntax) @@ -742,143 +739,142 @@ (def__ (untemplate-list tokens) (->' ($' List Syntax) Syntax) - (case' tokens - #Nil - (_meta (#Tag ["lux" "Nil"])) + (_lux_case tokens + #Nil + (_meta (#Tag ["lux" "Nil"])) - (#Cons [token tokens']) - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list token (untemplate-list tokens'))))))))) + (#Cons [token tokens']) + (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) + (_meta (#Tuple (list token (untemplate-list tokens'))))))))) (def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) - (case' xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) + (_lux_case xs + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) - #Nil - ys)) + #Nil + ys)) (defmacro #export ($ tokens) - (case' tokens - (#Cons [op (#Cons [init args])]) - (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) + (_lux_case tokens + (#Cons [op (#Cons [init args])]) + (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) + init + args))) + + _ + (fail "Wrong syntax for $"))) (def__ (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (case' (any? spliced? elems) - true - (let [elems' (map (:' (->' Syntax Syntax) - (lambda [elem] - (case' elem - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced + (_lux_case (any? spliced? elems) + true + (let [elems' (map (lambda [elem] + (_lux_case elem + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced - _ - ($form (list ($symbol ["" ":'"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) - 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))))))) + _ + ($form (list ($symbol ["" "_lux_:"]) + ($symbol ["lux" "SyntaxList"]) + ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))) + 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))))))) (def__ (untemplate subst token) (->' Text Syntax Syntax) - (case' token - (#Meta [_ (#Bool value)]) - (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) + (_lux_case token + (#Meta [_ (#Bool value)]) + (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) - (#Meta [_ (#Int value)]) - (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) + (#Meta [_ (#Int value)]) + (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) - (#Meta [_ (#Real value)]) - (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) + (#Meta [_ (#Real value)]) + (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) - (#Meta [_ (#Char value)]) - (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) + (#Meta [_ (#Char value)]) + (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) - (#Meta [_ (#Text value)]) - (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) + (#Meta [_ (#Text value)]) + (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) - (#Meta [_ (#Tag [module name])]) - (let [module' (case' module - "" - subst + (#Meta [_ (#Tag [module name])]) + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Symbol [module name])]) - (let [module' (case' module - "" - subst + (#Meta [_ (#Symbol [module name])]) + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Tuple elems)]) - (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) + (#Meta [_ (#Tuple elems)]) + (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) - unquoted + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) + unquoted - (#Meta [_ (#Form elems)]) - (splice (untemplate subst) ($tag ["lux" "Form"]) elems) + (#Meta [_ (#Form elems)]) + (splice (untemplate subst) ($tag ["lux" "Form"]) elems) - (#Meta [_ (#Record fields)]) - (wrap-meta ($form (list ($tag ["lux" "Record"]) - (untemplate-list (map (:' (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - ($tuple (list (untemplate subst k) (untemplate subst v)))))) - fields))))) - )) + (#Meta [_ (#Record fields)]) + (wrap-meta ($form (list ($tag ["lux" "Record"]) + (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (lambda [kv] + (let [[k v] kv] + ($tuple (list (untemplate subst k) (untemplate subst v)))))) + fields))))) + )) (defmacro (`' tokens) - (case' tokens - (#Cons [template #Nil]) - (return (list (untemplate "" template))) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate "" template))) - _ - (fail "Wrong syntax for `'"))) + _ + (fail "Wrong syntax for `'"))) (defmacro #export (|> tokens) - (case' tokens - (#Cons [init apps]) - (return (list (fold (lambda [acc app] - (case' app - (#Meta [_ (#Form parts)]) - ($form (list:++ parts (list acc))) + (_lux_case tokens + (#Cons [init apps]) + (return (list (fold (lambda [acc app] + (_lux_case app + (#Meta [_ (#Form parts)]) + ($form (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) - init - apps))) + _ + (`' ((~ app) (~ acc))))) + init + apps))) - _ - (fail "Wrong syntax for |>"))) + _ + (fail "Wrong syntax for |>"))) (defmacro #export (if tokens) - (case' tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (case' (~ test) - true (~ then) - false (~ else))))) + (_lux_case tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (`' (_lux_case (~ test) + true (~ then) + false (~ else))))) - _ - (fail "Wrong syntax for if"))) + _ + (fail "Wrong syntax for if"))) ## (deftype (Lux a) ## (-> CompilerState (Either Text (, CompilerState a)))) @@ -908,71 +904,71 @@ #lux;bind (lambda [f ma] - (case' ma - #None #None - (#Some a) (f a)))}) + (_lux_case ma + #None #None + (#Some a) (f a)))}) (def__ Lux:Monad ($' Monad Lux) {#lux;return - (lambda return [x] - (lambda [state] - (#Right [state x]))) + (lambda [x] + (lambda [state] + (#Right [state x]))) #lux;bind (lambda [f ma] (lambda [state] - (case' (ma state) - (#Left msg) - (#Left msg) + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right [state' a]) - (f a state'))))}) + (#Right [state' a]) + (f a state'))))}) (defmacro #export (^ tokens) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) - _ - (fail "Wrong syntax for ^"))) + _ + (fail "Wrong syntax for ^"))) (defmacro #export (-> tokens) - (case' (reverse tokens) - (#Cons [output inputs]) - (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) - output - inputs))) - - _ - (fail "Wrong syntax for ->"))) + (_lux_case (reverse tokens) + (#Cons [output inputs]) + (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) + + _ + (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) (return (list (`' (#;TupleT (;list (~@ tokens))))))) (defmacro (do tokens) - (case' tokens - (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) - (let [body' (fold (:' (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (case' var - (#Meta [_ (#Tag ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (lambda' (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (case' (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) - - _ - (fail "Wrong syntax for do"))) + (_lux_case tokens + (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) + (let [body' (fold (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (_lux_case var + (#Meta [_ (#Tag ["" "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) ## (All [m a b] @@ -983,16 +979,16 @@ ($' List (B' a)) ($' (B' m) ($' List (B' b))))) (let [{#;return ;return #;bind _} m] - (case' xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) + (_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) (All' [a b c] @@ -1002,21 +998,21 @@ (def__ (get-ident x) (-> Syntax ($' Maybe Text)) - (case' x - (#Meta [_ (#Symbol ["" sname])]) - (#Some sname) + (_lux_case x + (#Meta [_ (#Symbol ["" sname])]) + (#Some sname) - _ - #None)) + _ + #None)) (def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) - (case' tuple - (#Meta [_ (#Tuple members)]) - (#Some members) + (_lux_case tuple + (#Meta [_ (#Tuple members)]) + (#Some members) - _ - #None)) + _ + #None)) (def__ RepEnv Type @@ -1024,97 +1020,97 @@ (def__ (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) - (case' (:' (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) + (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + [xs ys]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) - _ - #Nil)) + _ + #Nil)) (def__ (text:= x y) (-> Text Text Bool) - (jvm-invokevirtual java.lang.Object equals [java.lang.Object] - x [y])) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y])) (def__ (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) - (case' env - #Nil - #None + (_lux_case env + #Nil + #None - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) (def__ (apply-template env template) (-> RepEnv Syntax Syntax) - (case' template - (#Meta [_ (#Symbol ["" sname])]) - (case' (get-rep sname env) - (#Some subst) - subst + (_lux_case template + (#Meta [_ (#Symbol ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst - _ - template) + _ + template) - (#Meta [_ (#Tuple elems)]) - ($tuple (map (apply-template env) elems)) + (#Meta [_ (#Tuple elems)]) + ($tuple (map (apply-template env) elems)) - (#Meta [_ (#Form elems)]) - ($form (map (apply-template env) elems)) + (#Meta [_ (#Form elems)]) + ($form (map (apply-template env) elems)) - (#Meta [_ (#Record members)]) - ($record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) + (#Meta [_ (#Record members)]) + ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) - _ - template)) + _ + template)) (def__ (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) - (case' xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro (do-template tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) - (case' (:' (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe:Monad get-ident bindings) - (map% Maybe:Monad tuple->list data)]) - [(#Some bindings') (#Some data')] - (let [apply (:' (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) + +(defmacro #export (do-template tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(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)) - _ - (fail "All the do-template bindigns must be symbols.")) + _ + (fail "All the do-template bindigns must be symbols.")) - _ - (fail "Wrong syntax for do-template"))) + _ + (fail "Wrong syntax for do-template"))) (do-template [ ] [(def__ #export ( x y) (-> Bool) ( x y))] - [int:= jvm-leq Int] - [int:> jvm-lgt Int] - [int:< jvm-llt Int] - [real:= jvm-deq Real] - [real:> jvm-dgt Real] - [real:< jvm-dlt Real] + [int:= _jvm_leq Int] + [int:> _jvm_lgt Int] + [int:< _jvm_llt Int] + [real:= _jvm_deq Real] + [real:> _jvm_dgt Real] + [real:< _jvm_dlt Real] ) (do-template [ ] @@ -1122,16 +1118,16 @@ (-> ) ( x y))] - [int:+ jvm-ladd Int] - [int:- jvm-lsub Int] - [int:* jvm-lmul Int] - [int:/ jvm-ldiv Int] - [int:% jvm-lrem Int] - [real:+ jvm-dadd Real] - [real:- jvm-dsub Real] - [real:* jvm-dmul Real] - [real:/ jvm-ddiv Real] - [real:% jvm-drem Real] + [int:+ _jvm_ladd Int] + [int:- _jvm_lsub Int] + [int:* _jvm_lmul Int] + [int:/ _jvm_ldiv Int] + [int:% _jvm_lrem Int] + [real:+ _jvm_dadd Real] + [real:- _jvm_dsub Real] + [real:* _jvm_dmul Real] + [real:/ _jvm_ddiv Real] + [real:% _jvm_drem Real] ) (def__ (multiple? div n) @@ -1148,8 +1144,8 @@ (def__ #export (text:++ x y) (-> Text Text Text) - (jvm-invokevirtual java.lang.String concat [java.lang.String] - x [y])) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) (def__ (ident->text ident) (-> Ident Text) @@ -1158,88 +1154,88 @@ (def__ (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) - (case' syntax - (#Meta [_ (#Symbol ["" name])]) - (case' (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - (#Meta [_ (#Form parts)]) - (#Meta [_ (#Form (map (replace-syntax reps) parts))]) - - (#Meta [_ (#Tuple members)]) - (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) - - (#Meta [_ (#Record slots)]) - (#Meta [_ (#Record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) + (_lux_case syntax + (#Meta [_ (#Symbol ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + (#Meta [_ (#Form parts)]) + (#Meta [_ (#Form (map (replace-syntax reps) parts))]) + + (#Meta [_ (#Tuple members)]) + (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) + + (#Meta [_ (#Record slots)]) + (#Meta [_ (#Record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) + + _ + syntax) ) (defmacro #export (All tokens) - (let [[self-ident tokens'] (:' (, Text SyntaxList) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (case' tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) - (case' (map% Maybe:Monad get-ident args) - (#Some idents) - (case' idents - #Nil - (return (list body)) - - (#Cons [harg targs]) - (let [replacements (map (:' (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) - (list& self-ident idents)) - body' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) + (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#Tuple 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' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) + (replace-syntax replacements body) + (reverse targs))] + (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) )) (def__ (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) - (case' plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) - #Nil - #None)) + #Nil + #None)) (def__ #export (get-module-name state) ($' Lux Text) - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (case' (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) (def__ (find-macro' modules current-module module name) (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) @@ -1248,19 +1244,19 @@ (do Maybe:Monad [bindings (get module modules) gdef (get name bindings)] - (case' (:' (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) + (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) (def__ #export (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) @@ -1268,53 +1264,63 @@ [current-module get-module-name] (let [[module name] ident] (lambda [state] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (#Right [state (find-macro' modules current-module module name)])))))) + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (#Right [state (find-macro' modules current-module module name)])))))) (def__ (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) +## (def__ #export (normalize ident) +## (-> Ident ($' Lux Ident)) +## (_lux_case ident +## ["" name] +## (do Lux:Monad +## [module-name get-module-name] +## (;return (: Ident [module-name name]))) + +## _ +## (return ident))) (def__ #export (normalize ident state) (-> Ident ($' Lux Ident)) - (case' ident - ["" name] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (case' (reverse envs) - #Nil - (#Left "Can't normalize Ident without a global environment.") + (_lux_case ident + ["" name] + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't normalize Ident without a global environment.") - (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) - (#Right [state [prefix name]]))) - - _ - (#Right [state ident]))) + (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) + (#Right [state [prefix name]]))) + + _ + (#Right [state ident]))) (defmacro #export (| tokens) (do Lux:Monad [pairs (map% Lux:Monad - (:' (-> Syntax ($' Lux Syntax)) - (lambda [token] - (case' token - (#Meta [_ (#Tag ident)]) - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (;,)]))) - - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for |")))) + (_lux_: (-> Syntax ($' Lux Syntax)) + (lambda [token] + (_lux_case token + (#Meta [_ (#Tag ident)]) + (do Lux:Monad + [ident (normalize ident)] + (;return (`' [(~ ($text (ident->text ident))) (;,)]))) + + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) + (do Lux:Monad + [ident (normalize ident)] + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for |")))) tokens)] (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) @@ -1323,264 +1329,267 @@ (fail "& expects an even number of arguments.") (do Lux:Monad [pairs (map% Lux:Monad - (:' (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (case' pair - [(#Meta [_ (#Tag ident)]) value] - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) + (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) + (lambda [pair] + (_lux_case pair + [(#Meta [_ (#Tag ident)]) value] + (do Lux:Monad + [ident (normalize ident)] + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for &")))) (as-pairs tokens))] (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) (def__ #export (->text x) (-> (^ java.lang.Object) Text) - (jvm-invokevirtual java.lang.Object toString [] x [])) + (_jvm_invokevirtual java.lang.Object toString [] x [])) (def__ #export (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) - (case' xs - #Nil - xs + (_lux_case xs + #Nil + xs - (#Cons [x #Nil]) - xs + (#Cons [x #Nil]) + xs - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) (def__ #export (syntax:show syntax) (-> Syntax Text) - (case' syntax - (#Meta [_ (#Bool value)]) - (->text value) + (_lux_case syntax + (#Meta [_ (#Bool value)]) + (->text value) - (#Meta [_ (#Int value)]) - (->text value) + (#Meta [_ (#Int value)]) + (->text value) - (#Meta [_ (#Real value)]) - (->text value) + (#Meta [_ (#Real value)]) + (->text value) - (#Meta [_ (#Char value)]) - ($ text:++ "#\"" (->text value) "\"") + (#Meta [_ (#Char value)]) + ($ text:++ "#\"" (->text value) "\"") - (#Meta [_ (#Text value)]) - value + (#Meta [_ (#Text value)]) + value - (#Meta [_ (#Symbol ident)]) - (ident->text ident) + (#Meta [_ (#Symbol ident)]) + (ident->text ident) - (#Meta [_ (#Tag ident)]) - (text:++ "#" (ident->text ident)) + (#Meta [_ (#Tag ident)]) + (text:++ "#" (ident->text ident)) - (#Meta [_ (#Tuple members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + (#Meta [_ (#Tuple members)]) + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") - (#Meta [_ (#Form members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + (#Meta [_ (#Form members)]) + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") - (#Meta [_ (#Record slots)]) - ($ text:++ "{" (|> slots - (map (:' (-> (, Syntax Syntax) Text) - (lambda [slot] - (let [[k v] slot] - ($ text:++ (syntax:show k) " " (syntax:show v)))))) - (interpose " ") (fold text:++ "")) "}") - )) + (#Meta [_ (#Record slots)]) + ($ text:++ "{" + (|> slots + (map (_lux_: (-> (, Syntax Syntax) Text) + (lambda [slot] + (let [[k v] slot] + ($ text:++ (syntax:show k) " " (syntax:show v)))))) + (interpose " ") + (fold text:++ "")) + "}") + )) (def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) - (case' syntax - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) - (do Lux:Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case' ?macro - (#Some macro) - (do Lux:Monad - [expansion (macro args) - expansion' (map% Lux:Monad macro-expand expansion)] - (;return (list:join expansion'))) - - #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (list ($form (list:join parts'))))))) - - (#Meta [_ (#Form (#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+)))))) - - (#Meta [_ (#Tuple members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (list ($tuple (list:join members'))))) - - _ - (return (list syntax)))) + (_lux_case syntax + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) + (do Lux:Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (map% Lux:Monad macro-expand expansion)] + (;return (list:join expansion'))) + + #None + (do Lux:Monad + [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] + (;return (list ($form (list:join parts'))))))) + + (#Meta [_ (#Form (#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+)))))) + + (#Meta [_ (#Tuple members)]) + (do Lux:Monad + [members' (map% Lux:Monad macro-expand members)] + (;return (list ($tuple (list:join members'))))) + + _ + (return (list syntax)))) (def__ (walk-type type) (-> Syntax Syntax) - (case' type - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) + (_lux_case type + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) + ($form (#Cons [($tag tag) (map walk-type parts)])) - (#Meta [_ (#Tuple members)]) - ($tuple (map walk-type members)) + (#Meta [_ (#Tuple members)]) + ($tuple (map walk-type members)) - (#Meta [_ (#Form (#Cons [type-fn args]))]) - (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) + (#Meta [_ (#Form (#Cons [type-fn args]))]) + (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) (defmacro #export (type` tokens) - (case' tokens - (#Cons [type #Nil]) - (do Lux:Monad - [type+ (macro-expand type)] - (case' type+ - (#Cons [type' #Nil]) - (;return (list (walk-type type'))) - - _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for type`"))) + (_lux_case tokens + (#Cons [type #Nil]) + (do Lux:Monad + [type+ (macro-expand type)] + (_lux_case type+ + (#Cons [type' #Nil]) + (;return (list (walk-type type'))) + + _ + (fail "type`: The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type`"))) (defmacro #export (: tokens) - (case' tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (:' (;type` (~ type)) (~ value))))) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_: (;type` (~ type)) (~ value))))) - _ - (fail "Wrong syntax for :"))) + _ + (fail "Wrong syntax for :"))) (defmacro #export (:! tokens) - (case' tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (:!' (;type` (~ type)) (~ value))))) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_:! (;type` (~ type)) (~ value))))) - _ - (fail "Wrong syntax for :!"))) + _ + (fail "Wrong syntax for :!"))) (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) - [true tokens'] + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) - (case' tokens' - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) - - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) - - _ - #None))] - (case' parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (export' (~ name)))) - #Nil)) - type' (: Syntax - (case' args - #Nil - type - - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (list& (`' (def' (~ name) (;type` (~ type')))) - with-export))) - - #None - (fail "Wrong syntax for deftype")) + (_lux_case tokens' + (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) + (#Some [($symbol name) #Nil type]) + + (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) + (#Some [($symbol name) args type]) + + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)) + type' (: Syntax + (_lux_case args + #Nil + type + + _ + (`' (;All (~ name) [(~@ args)] (~ 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) - (case' tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (list (`' (lambda' (~ blank) (~ blank) (~ value)))))) + (_lux_case tokens + (#Cons [value #Nil]) + (let [blank ($symbol ["" ""])] + (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))) - _ - (fail "Wrong syntax for io"))) + _ + (fail "Wrong syntax for io"))) (defmacro #export (exec tokens) - (case' (reverse tokens) - (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] - (return (list (fold (lambda [post pre] (`' (case' (~ pre) (~ dummy) (~ post)))) - value - actions)))) + (_lux_case (reverse tokens) + (#Cons [value actions]) + (let [dummy ($symbol ["" ""])] + (return (list (fold (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) - _ - (fail "Wrong syntax for exec"))) + _ + (fail "Wrong syntax for exec"))) (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) - [true tokens'] + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (case' tokens' - (#Cons [(#Meta [_ (#Form (#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 [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#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& (`' (def' (~ name) (~ body''))) - (if export? - (list (`' (export' (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) + (_lux_case tokens' + (#Cons [(#Meta [_ (#Form (#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 [_ (#Form (#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 + + _ + (`' (;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) (-> (, Syntax Syntax) (List Syntax)) @@ -1588,28 +1597,28 @@ (list left right))) (defmacro #export (case tokens) - (case' tokens - (#Cons [value branches]) - (do Lux:Monad - [expansions (map% Lux:Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (case' pattern - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol 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 (`' (case' (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - - _ - (fail "Wrong syntax for case"))) + (_lux_case tokens + (#Cons [value branches]) + (do Lux:Monad + [expansions (map% Lux:Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol 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))))))) + + _ + (fail "Wrong syntax for case"))) (defmacro #export (\ tokens) (case tokens @@ -1650,8 +1659,8 @@ (def (int:show int) (-> Int Text) - (jvm-invokevirtual java.lang.Object toString [] - int [])) + (_jvm_invokevirtual java.lang.Object toString [] + int [])) (defmacro #export (` tokens) (do Lux:Monad @@ -1692,7 +1701,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" ":'"])]) type (#Meta [_ (#Symbol name)])))])) + (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_:"])]) type (#Meta [_ (#Symbol name)])))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1734,9 +1743,9 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (def' (~ name) (~ sigs'))) + (return (list& (`' (_lux_def (~ name) (~ sigs'))) (if export? - (list (`' (export' (~ name)))) + (list (`' (_lux_export (~ name)))) #Nil)))) #None @@ -1749,7 +1758,7 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "def'"])]) (#Meta [_ (#Symbol name)]) value))])) + (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_def"])]) (#Meta [_ (#Symbol name)]) value))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [($tag name') value]))) @@ -1788,7 +1797,7 @@ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] (return (list& (`' (def (~ name) (~ type) (~ defs'))) (if export? - (list (`' (export' (~ name)))) + (list (`' (_lux_export (~ name)))) #Nil)))) #None @@ -1803,8 +1812,8 @@ (def (= x y) ( x y)))] - [Int:Eq Int jvm-leq] - [Real:Eq Real jvm-deq]) + [Int:Eq Int _jvm_leq] + [Real:Eq Real _jvm_deq]) (def #export (id x) (All [a] (-> a a)) @@ -1852,17 +1861,20 @@ [(defstruct #export (Ord ) (def (< x y) ( x y)) + (def (<= x y) (or ( x y) ( x y))) + (def (> x y) ( x y)) + (def (>= x y) (or ( x y) ( x y))))] - [Int:Ord Int jvm-llt jvm-lgt jvm-leq] - [Real:Ord Real jvm-dlt jvm-dgt jvm-deq]) + [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] + [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) (defmacro #export (alias-lux tokens state) (case state @@ -1880,8 +1892,7 @@ (list))))) lux)] (#Right [state (map (lambda [name] - (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name])) - (~ ($symbol ["lux" name]))))) + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))) (list:join to-alias))])) #None @@ -1890,8 +1901,8 @@ (def #export (print x) (-> Text (,)) - (jvm-invokevirtual java.io.PrintStream print [java.lang.Object] - (jvm-getstatic java.lang.System out) [x])) + (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x])) (def #export (println x) (-> Text (,)) @@ -1915,18 +1926,18 @@ (def (index-of part text) (-> Text Text Int) - (jvm-i2l (jvm-invokevirtual java.lang.String indexOf [java.lang.String] - text [part]))) + (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + text [part]))) (def (substring1 idx text) (-> Int Text Text) - (jvm-invokevirtual java.lang.String substring [int] - text [(jvm-l2i idx)])) + (_jvm_invokevirtual java.lang.String substring [int] + text [(_jvm_l2i idx)])) (def (substring2 idx1 idx2 text) (-> Int Int Text Text) - (jvm-invokevirtual java.lang.String substring [int int] - text [(jvm-l2i idx1) (jvm-l2i idx2)])) + (_jvm_invokevirtual java.lang.String substring [int int] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) (def (split-slot slot) (-> Text (, Text Text)) @@ -1986,22 +1997,22 @@ [($tag [module name]) ($symbol ["" name])]))) slots)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (list (` (case' (~ struct) (~ pattern) (~ body))))])) + (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (list (` (case' (~ struct) - (~ dummy) - (using (~ dummy) (~ body)))))]))) + (#Right [state (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) (~ body)))))]))) _ (#Left "Wrong syntax for defsig"))) ## (defmacro (loop tokens) -## (case' tokens +## (_lux_case tokens ## (#Cons [bindings (#Cons [body #Nil])]) ## (let [pairs (as-pairs bindings)] ## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs))) @@ -2009,7 +2020,7 @@ ## (map second pairs)]))))))) ## (defmacro (get@ tokens) -## (let [output (case' tokens +## (let [output (_lux_case tokens ## (#Cons [tag (#Cons [record #Nil])]) ## (` (get@' (~ tag) (~ record))) @@ -2018,7 +2029,7 @@ ## (return (list output)))) ## (defmacro (set@ tokens) -## (let [output (case' tokens +## (let [output (_lux_case tokens ## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) ## (` (set@' (~ tag) (~ value) (~ record))) @@ -2030,7 +2041,7 @@ ## (return (list output)))) ## (defmacro (update@ tokens) -## (let [output (case' tokens +## (let [output (_lux_case tokens ## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) ## (` (let [_record_ (~ record)] ## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) diff --git a/source/program.lux b/source/program.lux index 2bbf3fd4f..20f7863ab 100644 --- a/source/program.lux +++ b/source/program.lux @@ -11,8 +11,8 @@ (list& x (filter p xs')) (filter p xs')))) -(jvm-program _ - (exec (println "Hello, world!") - (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) - (println (->text (using Int:Ord - (< 5 10)))))) +(_jvm_program _ + (exec (println "Hello, world!") + (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) + (println (->text (using Int:Ord + (< 5 10)))))) -- cgit v1.2.3 From 5a13be9d9646819a00c281cea759f5b1c2eb883b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 10 May 2015 21:12:56 -0400 Subject: - Changed the names of the tags of the Syntax type to differentiate them better from the tags of the Type type. --- source/lux.lux | 452 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 226 insertions(+), 226 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index f2a6f70da..3b7bb9702 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -131,16 +131,16 @@ (_lux_export Meta) ## (deftype (Syntax' w) -## (| (#Bool Bool) -## (#Int Int) -## (#Real Real) -## (#Char Char) -## (#Text Text) -## (#Symbol (, Text Text)) -## (#Tag (, Text Text)) -## (#Form (List (w (Syntax' w)))) -## (#Tuple (List (w (Syntax' w)))) -## (#Record (List (, (w (Syntax' w)) (w (Syntax' w))))))) +## (| (#BoolS Bool) +## (#IntS Int) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS (, Text Text)) +## (#TagS (, Text Text)) +## (#FormS (List (w (Syntax' w)))) +## (#TupleS (List (w (Syntax' w)))) +## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) (_lux_def Syntax' (_lux_case (#AppT [(#BoundT "w") (#AppT [(#BoundT "Syntax'") @@ -149,16 +149,16 @@ (_lux_case (#AppT [List Syntax]) SyntaxList (#AllT [#None "Syntax'" "w" - (#VariantT (#Cons [["lux;Bool" Bool] - (#Cons [["lux;Int" Int] - (#Cons [["lux;Real" Real] - (#Cons [["lux;Char" Char] - (#Cons [["lux;Text" Text] - (#Cons [["lux;Symbol" Ident] - (#Cons [["lux;Tag" Ident] - (#Cons [["lux;Form" SyntaxList] - (#Cons [["lux;Tuple" SyntaxList] - (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] #Nil]) ])])])])])])])])]) )])))) @@ -319,32 +319,32 @@ (_lux_def $text (_lux_: (#LambdaT [Text Syntax]) (_lux_lambda _ text - (_meta (#Text text))))) + (_meta (#TextS text))))) (_lux_def $symbol (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident - (_meta (#Symbol ident))))) + (_meta (#SymbolS ident))))) (_lux_def $tag (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident - (_meta (#Tag ident))))) + (_meta (#TagS ident))))) (_lux_def $form (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens - (_meta (#Form tokens))))) + (_meta (#FormS tokens))))) (_lux_def $tuple (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens - (_meta (#Tuple tokens))))) + (_meta (#TupleS tokens))))) (_lux_def $record (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) (_lux_lambda _ tokens - (_meta (#Record tokens))))) + (_meta (#RecordS tokens))))) (_lux_def let' (_lux_: Macro @@ -363,34 +363,34 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) - (#Cons [(_meta (#Symbol ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) #Nil])) - (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) - (#Cons [(_meta (#Symbol self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) #Nil])) _ @@ -401,55 +401,55 @@ (_lux_: Macro (lambda_ [tokens] (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #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 [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #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 [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #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 (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #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])) _ @@ -460,7 +460,7 @@ (def_ #export (defmacro tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (#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"]) @@ -470,7 +470,7 @@ (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #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])) @@ -491,18 +491,18 @@ (defmacro (->' tokens) (_lux_case tokens (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) #Nil])) (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) #Nil])) _ @@ -510,23 +510,23 @@ (defmacro (All' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple #Nil)]) + (#Cons [(#Meta [_ (#TupleS #Nil)]) (#Cons [body #Nil])]) (return (#Cons [body #Nil])) - (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) - (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) - (#Cons [(_meta (#Text "")) - (#Cons [(_meta (#Text arg-name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) - (#Cons [(_meta (#Tuple other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) #Nil])) _ @@ -534,11 +534,11 @@ (defmacro (B' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) #Nil]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) - (#Cons [(_meta (#Text bound-name)) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) #Nil])) _ @@ -550,11 +550,11 @@ (return tokens) (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) - (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) #Nil])) _ @@ -582,10 +582,10 @@ (defmacro #export (list xs) (return (#Cons [(fold (lambda_ [tail head] - (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) - (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#Tag ["lux" "Nil"])) + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) (reverse xs)) #Nil]))) @@ -593,8 +593,8 @@ (_lux_case (reverse xs) (#Cons [last init]) (return (list (fold (lambda_ [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list head tail))))))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) last init))) @@ -604,13 +604,13 @@ (defmacro #export (lambda tokens) (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol name)]) tokens']) + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda requires a non-empty arguments tuple.") @@ -632,8 +632,8 @@ (defmacro (def__ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) (return (list ($form (list ($symbol ["" "_lux_def"]) name @@ -645,7 +645,7 @@ body)))))) ($form (list ($symbol ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list ($form (list ($symbol ["" "_lux_def"]) name ($form (list ($symbol ["" "_lux_:"]) @@ -653,7 +653,7 @@ body)))) ($form (list ($symbol ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (return (list ($form (list ($symbol ["" "_lux_def"]) name @@ -685,13 +685,13 @@ (defmacro #export (let tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) (return (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) Syntax) (lambda [body binding] (_lux_case binding [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) body (fold (lambda [tail head] (#Cons [head tail])) #Nil @@ -725,7 +725,7 @@ (def__ (spliced? token) (->' Syntax Bool) (_lux_case token - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) true _ @@ -733,19 +733,19 @@ (def__ (wrap-meta content) (->' Syntax Syntax) - (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) - (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1))))) - content))))))) + (_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) (->' ($' List Syntax) Syntax) (_lux_case tokens #Nil - (_meta (#Tag ["lux" "Nil"])) + (_meta (#TagS ["lux" "Nil"])) (#Cons [token tokens']) - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list token (untemplate-list tokens'))))))))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) (def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) @@ -772,7 +772,7 @@ true (let [elems' (map (lambda [elem] (_lux_case elem - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) spliced _ @@ -791,50 +791,50 @@ (def__ (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token - (#Meta [_ (#Bool value)]) - (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) + (#Meta [_ (#BoolS value)]) + (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) - (#Meta [_ (#Int value)]) - (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) + (#Meta [_ (#IntS value)]) + (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) - (#Meta [_ (#Real value)]) - (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) + (#Meta [_ (#RealS value)]) + (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) - (#Meta [_ (#Char value)]) - (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) + (#Meta [_ (#CharS value)]) + (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) - (#Meta [_ (#Text value)]) - (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) + (#Meta [_ (#TextS value)]) + (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) - (#Meta [_ (#Tag [module name])]) + (#Meta [_ (#TagS [module name])]) (let [module' (_lux_case module "" subst _ module)] - (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Symbol [module name])]) + (#Meta [_ (#SymbolS [module name])]) (let [module' (_lux_case module "" subst _ module)] - (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Tuple elems)]) - (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) + (#Meta [_ (#TupleS elems)]) + (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) unquoted - (#Meta [_ (#Form elems)]) - (splice (untemplate subst) ($tag ["lux" "Form"]) elems) + (#Meta [_ (#FormS elems)]) + (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) - (#Meta [_ (#Record fields)]) - (wrap-meta ($form (list ($tag ["lux" "Record"]) + (#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] @@ -855,7 +855,7 @@ (#Cons [init apps]) (return (list (fold (lambda [acc app] (_lux_case app - (#Meta [_ (#Form parts)]) + (#Meta [_ (#FormS parts)]) ($form (list:++ parts (list acc))) _ @@ -927,8 +927,8 @@ (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ (fail "Wrong syntax for ^"))) @@ -948,12 +948,12 @@ (defmacro (do tokens) (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) + (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) (let [body' (fold (_lux_: (-> Syntax (, Syntax Syntax) Syntax) (lambda [body' binding] (let [[var value] binding] (_lux_case var - (#Meta [_ (#Tag ["" "let"])]) + (#Meta [_ (#TagS ["" "let"])]) (`' (;let (~ value) (~ body'))) _ @@ -999,7 +999,7 @@ (def__ (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x - (#Meta [_ (#Symbol ["" sname])]) + (#Meta [_ (#SymbolS ["" sname])]) (#Some sname) _ @@ -1008,7 +1008,7 @@ (def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) (#Some members) _ @@ -1047,7 +1047,7 @@ (def__ (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template - (#Meta [_ (#Symbol ["" sname])]) + (#Meta [_ (#SymbolS ["" sname])]) (_lux_case (get-rep sname env) (#Some subst) subst @@ -1055,13 +1055,13 @@ _ template) - (#Meta [_ (#Tuple elems)]) + (#Meta [_ (#TupleS elems)]) ($tuple (map (apply-template env) elems)) - (#Meta [_ (#Form elems)]) + (#Meta [_ (#FormS elems)]) ($form (map (apply-template env) elems)) - (#Meta [_ (#Record members)]) + (#Meta [_ (#RecordS members)]) ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) (lambda [kv] (let [[slot value] kv] @@ -1083,7 +1083,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) [(map% Maybe:Monad get-ident bindings) (map% Maybe:Monad tuple->list data)]) @@ -1155,7 +1155,7 @@ (def__ (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax - (#Meta [_ (#Symbol ["" name])]) + (#Meta [_ (#SymbolS ["" name])]) (_lux_case (get-rep name reps) (#Some replacement) replacement @@ -1163,18 +1163,18 @@ #None syntax) - (#Meta [_ (#Form parts)]) - (#Meta [_ (#Form (map (replace-syntax reps) parts))]) + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - (#Meta [_ (#Tuple members)]) - (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - (#Meta [_ (#Record slots)]) - (#Meta [_ (#Record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) + (#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)]))) + slots))]) _ syntax) @@ -1183,13 +1183,13 @@ (defmacro #export (All tokens) (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) [self-ident tokens'] _ ["" tokens]))] (_lux_case tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case (map% Maybe:Monad get-ident args) (#Some idents) (_lux_case idents @@ -1309,12 +1309,12 @@ (_lux_: (-> Syntax ($' Lux Syntax)) (lambda [token] (_lux_case token - (#Meta [_ (#Tag ident)]) + (#Meta [_ (#TagS ident)]) (do Lux:Monad [ident (normalize ident)] (;return (`' [(~ ($text (ident->text ident))) (;,)]))) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) (do Lux:Monad [ident (normalize ident)] (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) @@ -1332,7 +1332,7 @@ (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) (lambda [pair] (_lux_case pair - [(#Meta [_ (#Tag ident)]) value] + [(#Meta [_ (#TagS ident)]) value] (do Lux:Monad [ident (normalize ident)] (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) @@ -1362,34 +1362,34 @@ (def__ #export (syntax:show syntax) (-> Syntax Text) (_lux_case syntax - (#Meta [_ (#Bool value)]) + (#Meta [_ (#BoolS value)]) (->text value) - (#Meta [_ (#Int value)]) + (#Meta [_ (#IntS value)]) (->text value) - (#Meta [_ (#Real value)]) + (#Meta [_ (#RealS value)]) (->text value) - (#Meta [_ (#Char value)]) + (#Meta [_ (#CharS value)]) ($ text:++ "#\"" (->text value) "\"") - (#Meta [_ (#Text value)]) + (#Meta [_ (#TextS value)]) value - (#Meta [_ (#Symbol ident)]) + (#Meta [_ (#SymbolS ident)]) (ident->text ident) - (#Meta [_ (#Tag ident)]) + (#Meta [_ (#TagS ident)]) (text:++ "#" (ident->text ident)) - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") - (#Meta [_ (#Form members)]) + (#Meta [_ (#FormS members)]) ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") - (#Meta [_ (#Record slots)]) + (#Meta [_ (#RecordS slots)]) ($ text:++ "{" (|> slots (map (_lux_: (-> (, Syntax Syntax) Text) @@ -1404,7 +1404,7 @@ (def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux:Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1420,13 +1420,13 @@ [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] (;return (list ($form (list:join parts'))))))) - (#Meta [_ (#Form (#Cons [harg targs]))]) + (#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+)))))) - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] (;return (list ($tuple (list:join members'))))) @@ -1437,13 +1437,13 @@ (def__ (walk-type type) (-> Syntax Syntax) (_lux_case type - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) ($form (#Cons [($tag tag) (map walk-type parts)])) - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) ($tuple (map walk-type members)) - (#Meta [_ (#Form (#Cons [type-fn args]))]) + (#Meta [_ (#FormS (#Cons [type-fn args]))]) (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1485,17 +1485,17 @@ (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) + (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) (#Some [($symbol name) #Nil type]) - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) (#Some [($symbol name) args type]) _ @@ -1546,20 +1546,20 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#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 [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (#Some [name args #None body]) (#Cons [name (#Cons [body #Nil])]) @@ -1605,7 +1605,7 @@ (lambda expander [branch] (let [[pattern body] branch] (_lux_case pattern - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]))]) + (#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))] @@ -1701,7 +1701,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_:"])]) type (#Meta [_ (#Symbol name)])))])) + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1719,14 +1719,14 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens')) + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#Form (list& name args))]) sigs)) + (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) (#Some [name args sigs]) (\ (list& name sigs)) @@ -1758,7 +1758,7 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_def"])]) (#Meta [_ (#Symbol 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]))) @@ -1771,14 +1771,14 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens')) + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#Form (list& name args))]) type defs)) + (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) (#Some [name args type defs]) (\ (list& name type defs)) @@ -1965,7 +1965,7 @@ (case tokens (\ (list struct body)) (case struct - (#Meta [_ (#Symbol vname)]) + (#Meta [_ (#SymbolS vname)]) (let [vname' (ident->text vname)] (case state {#source source #modules modules #module-aliases module-aliases @@ -2015,7 +2015,7 @@ ## (_lux_case tokens ## (#Cons [bindings (#Cons [body #Nil])]) ## (let [pairs (as-pairs bindings)] -## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs))) +## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs))) ## (~ body))) ## (map second pairs)]))))))) -- cgit v1.2.3 From c4ac3e692ae96d6898d8efb42faf4dfadd43f4ae Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 14 May 2015 08:23:10 -0400 Subject: - Removed the apparently unnecessary total-locals. --- source/lux.lux | 46 +++++++++++++++++++++++++++++++++------------- source/program.lux | 2 +- 2 files changed, 34 insertions(+), 14 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 3b7bb9702..1385cf8a5 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1876,7 +1876,7 @@ [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) -(defmacro #export (alias-lux tokens state) +(defmacro #export (lux tokens state) (case state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host @@ -2005,12 +2005,42 @@ _ (let [dummy ($symbol ["" ""])] (#Right [state (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) (~ body)))))]))) + (~ dummy) + (using (~ dummy) (~ body)))))]))) _ (#Left "Wrong syntax for defsig"))) +(defmacro #export (when tokens) + (case tokens + (\ (list test body)) + (return (list (` (if (~ test) + (#Some (~ body)) + #None)))) + + _ + (fail "Wrong syntax for when"))) + +(def #export (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 [[x y]] +## (f x y))) + ## (defmacro (loop tokens) ## (_lux_case tokens ## (#Cons [bindings (#Cons [body #Nil])]) @@ -2054,13 +2084,3 @@ ## (` (lambda [func record] ## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] ## (return (list output)))) - -## (do-template [ ] -## (def ( pair) -## (All [a b] (-> (, a b) )) -## (case pair -## [f s] -## )) - -## [first f a] -## [second s b]) diff --git a/source/program.lux b/source/program.lux index 20f7863ab..a9451580f 100644 --- a/source/program.lux +++ b/source/program.lux @@ -1,4 +1,4 @@ -(;alias-lux) +(;lux) (def (filter p xs) (All [a] (-> (-> a Bool) (List a) (List a))) -- cgit v1.2.3 From f52eb6df2e57f67e7cf30d85c6340ce00f923d6f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 22 May 2015 20:07:08 -0400 Subject: - Corrected the indentation issues in the lux files. - Temporarily reverted back to forward apply-analysis. - Fixed an error in lux.base/show-ast. - Reader now only returns a tuple instead of a full-blown #Meta variant. - Reader now doesn't cut the strings that it reads. Instead, the "cursor" just moves around, indicating where to read. - Inlined some calculations that previously relied on try-all%. --- source/lux.lux | 2069 +++++++++++++++++++++++++++------------------------- source/program.lux | 8 +- 2 files changed, 1074 insertions(+), 1003 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 1385cf8a5..e3f3ba243 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -37,22 +37,22 @@ ## (| #Nil ## (#Cons (, a (List a))))) (_lux_def List - (#AllT [#None "List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) + (#AllT [#None "List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) (_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [#None "Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) + (#AllT [#None "Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) (_lux_export Maybe) ## (deftype #rec Type @@ -66,37 +66,37 @@ ## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) ## (#AppT (, Type Type)))) (_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [#None "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [#None "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) (_lux_export Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings - (#AllT [#None "Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) + (#AllT [#None "Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) ## (deftype (Env k v) ## (& #name Text @@ -104,30 +104,30 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT [#None "Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) + (#AllT [#None "Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) ## (deftype Cursor ## (, Text Int Int)) (_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (_lux_def Meta - (#AllT [#None "Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) + (#AllT [#None "Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) (_lux_export Meta) ## (deftype (Syntax' w) @@ -142,34 +142,34 @@ ## (#TupleS (List (w (Syntax' w)))) ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) (_lux_def Syntax' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") - (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [#None "Syntax'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [#None "Syntax'" "w" + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) (_lux_export Syntax') ## (deftype Syntax ## (Meta Cursor (Syntax' (Meta Cursor)))) (_lux_def Syntax - (_lux_case (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) (_lux_export Syntax) (_lux_def SyntaxList (#AppT [List Syntax])) @@ -178,39 +178,39 @@ ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT [#None "_" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) + (#AllT [#None "_" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) (_lux_export Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [#None "StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) + (#AllT [#None "StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) ## (deftype Reader ## (List (Meta Cursor Text))) (_lux_def Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) (_lux_export Reader) ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader))) (_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - #Nil])]))) + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + #Nil])]))) ## (deftype (DefData' m) ## (| #TypeD @@ -218,20 +218,20 @@ ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [#None "DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) + (#AllT [#None "DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) ## (deftype LuxVar ## (| (#Local Int) ## (#Global Ident))) (_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) (_lux_export LuxVar) ## (deftype #rec CompilerState @@ -242,33 +242,33 @@ ## #types (Bindings Int Type) ## #host HostState)) (_lux_def CompilerState - (#AppT [(#AllT [#None "CompilerState" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") - (#BoundT "")])]) - SyntaxList])])]) - #Nil])])) - #Nil])]))]) - #Nil])]))])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - #Nil])])])])])])]))]) - Void])) + (#AppT [(#AllT [#None "CompilerState" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") + (#BoundT "")])]) + SyntaxList])])]) + #Nil])])) + #Nil])]))]) + #Nil])]))])] + (#Cons [["lux;module-aliases" (#AppT [List Void])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + #Nil])])])])])])]))]) + Void])) (_lux_export CompilerState) ## (deftype Macro ## (-> (List Syntax) (StateE CompilerState (List Syntax)))) (_lux_def Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) - SyntaxList])])) + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE CompilerState]) + SyntaxList])])) (_lux_export Macro) ## Base functions & macros @@ -276,11 +276,11 @@ ## (-> (Syntax' (Meta Cursor)) Syntax) ## (#Meta [["" -1 -1] data])) (_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (_lux_lambda _ data - (#Meta [["" -1 -1] data])))) + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [["" -1 -1] data])))) ## (def (return x) ## (All [a] @@ -288,16 +288,16 @@ ## (Either Text (, CompilerState a)))) ## ...) (_lux_def return - (_lux_: (#AllT [#None "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right [state val]))))) + (_lux_: (#AllT [#None "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) ## (def (fail msg) ## (All [a] @@ -305,260 +305,275 @@ ## (Either Text (, CompilerState a)))) ## ...) (_lux_def fail - (_lux_: (#AllT [#None "" "a" - (#LambdaT [Text - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) + (_lux_: (#AllT [#None "" "a" + (#LambdaT [Text + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) (_lux_def $text - (_lux_: (#LambdaT [Text Syntax]) - (_lux_lambda _ text - (_meta (#TextS text))))) + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) (_lux_def $symbol - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) (_lux_def $tag - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#TagS ident))))) + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) (_lux_def $form - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) (_lux_def $tuple - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) (_lux_def $record - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (_lux_lambda _ tokens - (_meta (#RecordS tokens))))) + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) (_lux_def let' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil])) - - _ - (fail "Wrong syntax for let'"))))) + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil]))) + + _ + (fail "Wrong syntax for let'"))))) (_lux_declare-macro let') (_lux_def lambda_ - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - _ - (fail "Wrong syntax for lambda"))))) + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil]))) + + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil]))) + + _ + (fail "Wrong syntax for lambda"))))) (_lux_declare-macro lambda_) (_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])) - - _ - (fail "Wrong syntax for def") - )))) + (_lux_: Macro + (lambda_ [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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_) (def_ #export (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"]) - (#Cons [body - #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"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro"))) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#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])])) + #Nil])]))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#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])])) + #Nil])]))) + + _ + (fail "Wrong syntax for defmacro"))) (_lux_declare-macro defmacro) (defmacro #export (comment tokens) - (return #Nil)) + (return (_lux_: SyntaxList #Nil))) (defmacro (->' tokens) (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for ->'"))) + (#Cons [input (#Cons [output #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil]))) + + (#Cons [input (#Cons [output others])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil]))) + + _ + (fail "Wrong syntax for ->'"))) (defmacro (All' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for All'"))) + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [body + #Nil]))) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil]))) + + _ + (fail "Wrong syntax for All'"))) (defmacro (B' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil])) + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + #Nil]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil]))) - _ - (fail "Wrong syntax for B'"))) + _ + (fail "Wrong syntax for B'"))) (defmacro ($' tokens) (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) + (#Cons [x #Nil]) + (return tokens) + + (#Cons [x (#Cons [y xs])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil]))) - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) - - _ - (fail "Wrong syntax for $'"))) + _ + (fail "Wrong syntax for $'"))) (def_ #export (fold f init xs) (All' [a b] @@ -567,169 +582,182 @@ ($' List (B' b)) (B' a))) (_lux_case xs - #Nil - init + #Nil + init - (#Cons [x xs']) - (fold f (f init x) xs'))) + (#Cons [x xs']) + (fold f (f init x) xs'))) (def_ #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (fold (lambda_ [tail head] (#Cons [head tail])) + (fold (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda_ [tail head] + (#Cons [head tail]))) #Nil list)) (defmacro #export (list xs) - (return (#Cons [(fold (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]))) + (return (_lux_: SyntaxList + (#Cons [(fold (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])))) (defmacro #export (list& xs) (_lux_case (reverse xs) - (#Cons [last init]) - (return (list (fold (lambda_ [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init))) + (#Cons [last init]) + (return (_lux_: SyntaxList + (list (fold (lambda_ [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init)))) - _ - (fail "Wrong syntax for list&"))) + _ + (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'] + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] - _ - [["" ""] 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 - (fold (lambda_ [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs))))))) - - _ - (fail "Wrong syntax for lambda")))) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol name) + harg + (fold (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]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - body)))) - ($form (list ($symbol ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) type body)))))) - - _ - (fail "Wrong syntax for def") - )) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "_lux_export"]) name))))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + body)))) + ($form (list ($symbol ["" "_lux_export"]) name))))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body))))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) type body))))))) + + _ + (fail "Wrong syntax for def") + )) (def__ (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) - _ - #Nil)) + _ + #Nil)) (defmacro #export (let tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) - body - (fold (lambda [tail head] (#Cons [head tail])) - #Nil - (as-pairs bindings))))) - - _ - (fail "Wrong syntax for let"))) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + body + (fold (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda [tail head] (#Cons [head tail]))) + #Nil + (as-pairs bindings)))))) + + _ + (fail "Wrong syntax for let"))) (def__ #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs - #Nil - #Nil + #Nil + #Nil - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) (def__ #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs - #Nil - false + #Nil + false - (#Cons [x xs']) - (_lux_case (p x) - true true - false (any? p xs')))) + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) (def__ (spliced? token) (->' Syntax Bool) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) - true + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + true - _ - false)) + _ + false)) (def__ (wrap-meta content) (->' Syntax Syntax) @@ -740,141 +768,147 @@ (def__ (untemplate-list tokens) (->' ($' List Syntax) Syntax) (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) + #Nil + (_meta (#TagS ["lux" "Nil"])) - (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) (def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) - #Nil - ys)) + #Nil + ys)) (defmacro #export ($ tokens) (_lux_case tokens - (#Cons [op (#Cons [init args])]) - (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) + (#Cons [op (#Cons [init args])]) + (return (_lux_: SyntaxList + (list (fold (lambda [a1 a2] ($form (list op a1 a2))) + init + args)))) + + _ + (fail "Wrong syntax for $"))) (def__ (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_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_:"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))) - 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))))))) + true + (let [elems' (map (_lux_: (->' Syntax Syntax) + (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + ($form (list ($symbol ["" "_lux_:"]) + ($symbol ["lux" "SyntaxList"]) + ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) + 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))))))) (def__ (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token - (#Meta [_ (#BoolS value)]) - (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) + (#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))))) + (#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))))) + (#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))))) + (#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))))) + (#Meta [_ (#TextS value)]) + (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) - (#Meta [_ (#TagS [module name])]) - (let [module' (_lux_case module - "" - subst + (#Meta [_ (#TagS [module name])]) + (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 + (#Meta [_ (#SymbolS [module name])]) + (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 (untemplate subst) ($tag ["lux" "TupleS"]) elems) + (#Meta [_ (#TupleS elems)]) + (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) - unquoted + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) + unquoted - (#Meta [_ (#FormS elems)]) - (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) + (#Meta [_ (#FormS elems)]) + (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) - (#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 subst k) (untemplate subst v)))))) - fields))))) - )) + (#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 subst k) (untemplate subst v)))))) + fields))))) + )) (defmacro (`' tokens) (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate "" template))) + (#Cons [template #Nil]) + (return (_lux_: SyntaxList + (list (untemplate "" template)))) - _ - (fail "Wrong syntax for `'"))) + _ + (fail "Wrong syntax for `'"))) (defmacro #export (|> tokens) (_lux_case tokens - (#Cons [init apps]) - (return (list (fold (lambda [acc app] - (_lux_case app - (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) + (#Cons [init apps]) + (return (_lux_: SyntaxList + (list (fold (_lux_: (->' Syntax Syntax Syntax) + (lambda [acc app] + (_lux_case app + (#Meta [_ (#FormS parts)]) + ($form (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) - init - apps))) + _ + (`' ((~ app) (~ acc)))))) + init + apps)))) - _ - (fail "Wrong syntax for |>"))) + _ + (fail "Wrong syntax for |>"))) (defmacro #export (if tokens) (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (_lux_case (~ test) - true (~ then) - false (~ else))))) + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (_lux_: SyntaxList + (list (`' (_lux_case (~ test) + true (~ then) + false (~ else)))))) - _ - (fail "Wrong syntax for if"))) + _ + (fail "Wrong syntax for if"))) ## (deftype (Lux a) ## (-> CompilerState (Either Text (, CompilerState a)))) @@ -905,8 +939,8 @@ #lux;bind (lambda [f ma] (_lux_case ma - #None #None - (#Some a) (f a)))}) + #None #None + (#Some a) (f a)))}) (def__ Lux:Monad ($' Monad Lux) @@ -919,56 +953,61 @@ (lambda [f ma] (lambda [state] (_lux_case (ma state) - (#Left msg) - (#Left msg) + (#Left msg) + (#Left msg) - (#Right [state' a]) - (f a state'))))}) + (#Right [state' a]) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (_lux_: SyntaxList + (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))) - _ - (fail "Wrong syntax for ^"))) + _ + (fail "Wrong syntax for ^"))) (defmacro #export (-> tokens) (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) - output - inputs))) - - _ - (fail "Wrong syntax for ->"))) + (#Cons [output inputs]) + (return (_lux_: SyntaxList + (list (fold (_lux_: (->' Syntax Syntax Syntax) + (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) + output + inputs)))) + + _ + (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (list (`' (#;TupleT (;list (~@ tokens))))))) + (return (_lux_: SyntaxList + (list (`' (#;TupleT (;list (~@ tokens)))))))) (defmacro (do tokens) (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (fold (_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"))) + (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) + (let [body' (fold (_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 (_lux_: SyntaxList + (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))))) + + _ + (fail "Wrong syntax for do"))) (def__ (map% m f xs) ## (All [m a b] @@ -980,15 +1019,15 @@ ($' (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]))) - ))) + #Nil + (;return (_lux_: List #Nil)) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (_lux_: List (#Cons [y ys])))) + ))) (def__ #export (. f g) (All' [a b c] @@ -999,20 +1038,20 @@ (def__ (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) - (#Some sname) + (#Meta [_ (#SymbolS ["" sname])]) + (#Some sname) - _ - #None)) + _ + #None)) (def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple - (#Meta [_ (#TupleS members)]) - (#Some members) + (#Meta [_ (#TupleS members)]) + (#Some members) - _ - #None)) + _ + #None)) (def__ RepEnv Type @@ -1022,11 +1061,11 @@ (-> ($' List Text) ($' List Syntax) RepEnv) (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) - _ - #Nil)) + _ + #Nil)) (def__ (text:= x y) (-> Text Text Bool) @@ -1036,69 +1075,69 @@ (def__ (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) (_lux_case env - #Nil - #None + #Nil + #None - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) (def__ (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) - (_lux_case (get-rep sname env) - (#Some subst) - subst + (#Meta [_ (#SymbolS ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst - _ - template) + _ + template) - (#Meta [_ (#TupleS elems)]) - ($tuple (map (apply-template env) elems)) + (#Meta [_ (#TupleS elems)]) + ($tuple (map (apply-template env) elems)) - (#Meta [_ (#FormS elems)]) - ($form (map (apply-template env) elems)) + (#Meta [_ (#FormS elems)]) + ($form (map (apply-template env) elems)) - (#Meta [_ (#RecordS members)]) - ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) + (#Meta [_ (#RecordS members)]) + ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) - _ - template)) + _ + template)) (def__ (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs - #Nil - #Nil + #Nil + #Nil - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(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)) - - _ - (fail "All the do-template bindigns must be symbols.")) - - _ - (fail "Wrong syntax for do-template"))) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(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)) + + _ + (fail "All the do-template bindigns must be symbols.")) + + _ + (fail "Wrong syntax for do-template"))) (do-template [ ] [(def__ #export ( x y) @@ -1155,87 +1194,91 @@ (def__ (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) - (_lux_case (get-rep name reps) - (#Some replacement) - replacement + (#Meta [_ (#SymbolS ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement - #None - syntax) - - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#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)]))) - slots))]) - - _ - syntax) + #None + syntax) + + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) + + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) + + (#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)]))) + slots))]) + + _ + syntax) ) (defmacro #export (All tokens) (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] - _ - ["" 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' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe:Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (_lux_: SyntaxList + (list body))) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) + (list& self-ident idents)) + body' (fold (_lux_: (-> Syntax Text Syntax) + (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + (replace-syntax replacements body) + (reverse targs))] + (return (_lux_: SyntaxList + (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) )) (def__ (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) - #Nil - #None)) + #Nil + #None)) (def__ #export (get-module-name state) ($' Lux Text) (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) (def__ (find-macro' modules current-module module name) (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) @@ -1245,18 +1288,18 @@ [bindings (get module modules) gdef (get name bindings)] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) (def__ #export (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) @@ -1265,10 +1308,10 @@ (let [[module name] ident] (lambda [state] (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (#Right [state (find-macro' modules current-module module name)])))))) + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (#Right [state (find-macro' modules current-module module name)])))))) (def__ (list:join xs) (All [a] @@ -1288,20 +1331,20 @@ (def__ #export (normalize ident state) (-> Ident ($' Lux Ident)) (_lux_case ident - ["" name] - (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (_lux_case (reverse envs) - #Nil - (#Left "Can't normalize Ident without a global environment.") - - (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) - (#Right [state [prefix name]]))) - - _ - (#Right [state ident]))) + ["" name] + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't normalize Ident without a global environment.") + + (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) + (#Right [state [prefix name]]))) + + _ + (#Right [state ident]))) (defmacro #export (| tokens) (do Lux:Monad @@ -1309,20 +1352,21 @@ (_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 |")))) + (#Meta [_ (#TagS ident)]) + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for |")))) tokens)] - (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) + (;return (_lux_: SyntaxList + (list (`' (#;VariantT (;list (~@ pairs))))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1332,15 +1376,16 @@ (_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 &")))) + [(#Meta [_ (#TagS ident)]) value] + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) + (;return (_lux_: SyntaxList + (list (`' (#;RecordT (;list (~@ pairs)))))))))) (def__ #export (->text x) (-> (^ java.lang.Object) Text) @@ -1350,174 +1395,179 @@ (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs - #Nil - xs + #Nil + xs - (#Cons [x #Nil]) - xs + (#Cons [x #Nil]) + xs - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) + (#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 [_ (#BoolS value)]) + (->text value) - (#Meta [_ (#IntS value)]) - (->text value) + (#Meta [_ (#IntS value)]) + (->text value) - (#Meta [_ (#RealS value)]) - (->text value) + (#Meta [_ (#RealS value)]) + (->text value) - (#Meta [_ (#CharS value)]) - ($ text:++ "#\"" (->text value) "\"") + (#Meta [_ (#CharS value)]) + ($ text:++ "#\"" (->text value) "\"") - (#Meta [_ (#TextS value)]) - value + (#Meta [_ (#TextS value)]) + value - (#Meta [_ (#SymbolS ident)]) - (ident->text ident) + (#Meta [_ (#SymbolS ident)]) + (ident->text ident) - (#Meta [_ (#TagS ident)]) - (text:++ "#" (ident->text ident)) + (#Meta [_ (#TagS ident)]) + (text:++ "#" (ident->text ident)) - (#Meta [_ (#TupleS members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + (#Meta [_ (#TupleS members)]) + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") - (#Meta [_ (#FormS members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + (#Meta [_ (#FormS members)]) + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold 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 " ") - (fold 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 " ") + (fold text:++ "")) + "}") + )) (def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux:Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (_lux_case ?macro - (#Some macro) - (do Lux:Monad - [expansion (macro args) - expansion' (map% Lux:Monad macro-expand expansion)] - (;return (list:join expansion'))) - - #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (list ($form (list:join parts'))))))) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux:Monad + [macro-name' (normalize macro-name) + ?macro (find-macro (_lux_: Ident macro-name'))] + (_lux_case (_lux_: ($' Maybe Macro) ?macro) + (#Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))] + (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion'))))) + + #None + (do Lux:Monad + [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] + (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) 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+)))))) + (#Meta [_ (#FormS (#Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))] + (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+)))))))) - (#Meta [_ (#TupleS members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (list ($tuple (list:join members'))))) + (#Meta [_ (#TupleS members)]) + (do Lux:Monad + [members' (map% Lux:Monad macro-expand members)] + (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members'))))))) - _ - (return (list syntax)))) + _ + (return (_lux_: SyntaxList (list syntax))))) (def__ (walk-type type) (-> Syntax Syntax) (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + ($form (#Cons [($tag tag) (map walk-type parts)])) - (#Meta [_ (#TupleS members)]) - ($tuple (map walk-type members)) + (#Meta [_ (#TupleS members)]) + ($tuple (map walk-type members)) - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (fold (_lux_: (-> Syntax Syntax Syntax) + (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) (defmacro #export (type` tokens) (_lux_case tokens - (#Cons [type #Nil]) - (do Lux:Monad - [type+ (macro-expand type)] - (_lux_case type+ - (#Cons [type' #Nil]) - (;return (list (walk-type type'))) - - _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) + (#Cons [type #Nil]) + (do Lux:Monad + [type+ (macro-expand type)] + (_lux_case (_lux_: SyntaxList type+) + (#Cons [type' #Nil]) + (;return (_lux_: SyntaxList + (list (walk-type type')))) + + _ + (fail "type`: 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))))) + (#Cons [type (#Cons [value #Nil])]) + (return (_lux_: SyntaxList + (list (`' (_lux_: (;type` (~ type)) (~ value)))))) - _ - (fail "Wrong syntax for :"))) + _ + (fail "Wrong syntax for :"))) (defmacro #export (:! tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_:! (;type` (~ type)) (~ value))))) + (#Cons [type (#Cons [value #Nil])]) + (return (_lux_: SyntaxList + (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) - _ - (fail "Wrong syntax for :!"))) + _ + (fail "Wrong syntax for :!"))) (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) + (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) + (#Some [($symbol name) #Nil type]) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) + (#Some [($symbol name) args type]) - _ - #None))] + _ + #None))] (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)) - type' (: Syntax - (_lux_case args - #Nil - type - - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (list& (`' (_lux_def (~ name) (;type` (~ type')))) - with-export))) - - #None - (fail "Wrong syntax for deftype")) + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)) + type' (: Syntax + (_lux_case args + #Nil + type + + _ + (`' (;All (~ name) [(~@ args)] (~ type)))))] + (return (_lux_: SyntaxList + (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export)))) + + #None + (fail "Wrong syntax for deftype")) )) (deftype #export (IO a) @@ -1525,71 +1575,75 @@ (defmacro #export (io tokens) (_lux_case tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))) + (#Cons [value #Nil]) + (let [blank ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (`' (_lux_lambda (~ blank) (~ blank) (~ value))))))) - _ - (fail "Wrong syntax for io"))) + _ + (fail "Wrong syntax for io"))) (defmacro #export (exec tokens) (_lux_case (reverse tokens) - (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] - (return (list (fold (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) - value - actions)))) + (#Cons [value actions]) + (let [dummy ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (fold (: (-> Syntax Syntax Syntax) + (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions))))) - _ - (fail "Wrong syntax for exec"))) + _ + (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'] + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] - _ - [false 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]) - - _ - #None))] + (#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 - - _ - (`' (;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")))) + (#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 (_lux_: SyntaxList + (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) + + #None + (fail "Wrong syntax for def")))) (def (rejoin-pair pair) (-> (, Syntax Syntax) (List Syntax)) @@ -1598,36 +1652,39 @@ (defmacro #export (case tokens) (_lux_case tokens - (#Cons [value branches]) - (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)))))) - (as-pairs branches))] - (;return (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - - _ - (fail "Wrong syntax for case"))) + (#Cons [value branches]) + (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 (: (List Syntax) expansion)))] + (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions))))) + + _ + (;return (: (List (, Syntax Syntax)) (list branch))))))) + (as-pairs branches))] + (;return (_lux_: SyntaxList + (list (`' (_lux_case (~ value) + (~@ (|> (: (List (List (, Syntax Syntax))) expansions) + list:join (map rejoin-pair) list:join)))))))) + + _ + (fail "Wrong syntax for case"))) (defmacro #export (\ tokens) (case tokens (#Cons [body (#Cons [pattern #Nil])]) (do Lux:Monad [pattern+ (macro-expand pattern)] - (case pattern+ + (case (: (List Syntax) pattern+) (#Cons [pattern' #Nil]) - (;return (list pattern' body)) + (;return (: (List Syntax) + (list pattern' body))) _ (fail "\\ can only expand to 1 pattern."))) @@ -1645,8 +1702,10 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (list:join (map (lambda [pattern] (list pattern body)) - (list:join patterns')))))) + (;return (_lux_: SyntaxList + (list:join (map (: (-> Syntax (List Syntax)) + (lambda [pattern] (list pattern body))) + (list:join patterns'))))))) _ (fail "Wrong syntax for \\or"))) @@ -1667,7 +1726,8 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (list (untemplate module-name template))) + (;return (_lux_: SyntaxList + (list (untemplate module-name template)))) _ (fail "Wrong syntax for `")))) @@ -1687,7 +1747,7 @@ (-> Syntax (Lux Syntax)) (do Lux:Monad [token+ (macro-expand token)] - (case token+ + (case (: (List Syntax) token+) (\ (list token')) (;return token') @@ -1709,12 +1769,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))))))))) + (;return (: (List Syntax) + (list (`' (#;RecordT (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)) @@ -1743,10 +1804,11 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) + (return (_lux_: SyntaxList + (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1766,7 +1828,8 @@ _ (fail "Structures require defined members!")))) tokens')] - (;return (list ($record members))))) + (;return (_lux_: SyntaxList + (list ($record members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1795,10 +1858,11 @@ _ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) + (return (_lux_: SyntaxList + (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1847,9 +1911,11 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (fold (lambda [post pre] (` )) - last - init))) + (return (: (List Syntax) + (list (fold (: (-> Syntax Syntax Syntax) + (lambda [post pre] (` ))) + last + init)))) _ (fail )))] @@ -1891,9 +1957,11 @@ (list name) (list))))) lux)] - (#Right [state (map (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))) - (list:join to-alias))])) + (#Right [state (_lux_: SyntaxList + (map (: (-> Text Syntax) + (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) + (list:join to-alias)))])) #None (#Left "Uh, oh... The universe is not working properly...")) @@ -1997,16 +2065,18 @@ [($tag [module name]) ($symbol ["" name])]))) slots)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))])) + (#Right [state (_lux_: SyntaxList + (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) (~ body)))))]))) + (#Right [state (_lux_: SyntaxList + (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) (~ body))))))]))) _ (#Left "Wrong syntax for defsig"))) @@ -2014,9 +2084,10 @@ (defmacro #export (when tokens) (case tokens (\ (list test body)) - (return (list (` (if (~ test) - (#Some (~ body)) - #None)))) + (return (_lux_: SyntaxList + (list (` (if (~ test) + (#Some (~ body)) + #None))))) _ (fail "Wrong syntax for when"))) diff --git a/source/program.lux b/source/program.lux index a9451580f..cefec07d4 100644 --- a/source/program.lux +++ b/source/program.lux @@ -12,7 +12,7 @@ (filter p xs')))) (_jvm_program _ - (exec (println "Hello, world!") - (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) - (println (->text (using Int:Ord - (< 5 10)))))) + (exec (println "Hello, world!") + (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) + (println (->text (using Int:Ord + (< 5 10)))))) -- cgit v1.2.3 From 1f0be2351bc76b0de15d97691f8ea0728d9ab321 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 22 May 2015 23:06:19 -0400 Subject: - Added a simple optimization based on the idea of avoiding to compare 2 type-functions which are most-likely the same, due to their name (remembering that when you define types using deftype, the type-function's name will correspond to the def's). - Gave empty environments to top-level type-functions, instead of leaving them with unset environments. --- source/lux.lux | 70 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 35 insertions(+), 35 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index e3f3ba243..9b5601eb4 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -37,10 +37,10 @@ ## (| #Nil ## (#Cons (, a (List a))))) (_lux_def List - (#AllT [#None "List" "a" + (#AllT [(#Some #Nil) "lux;List" "a" (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) #Nil])]))] #Nil])]))])) (_lux_export List) @@ -49,7 +49,7 @@ ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [#None "Maybe" "a" + (#AllT [(#Some #Nil) "lux;Maybe" "a" (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] (#Cons [["lux;Some" (#BoundT "a")] #Nil])]))])) @@ -70,7 +70,7 @@ Type (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) TypeEnv - (#AppT [(#AllT [#None "Type" "_" + (#AppT [(#AllT [(#Some #Nil) "Type" "_" (#VariantT (#Cons [["lux;DataT" Text] (#Cons [["lux;TupleT" (#AppT [List Type])] (#Cons [["lux;VariantT" TypeEnv] @@ -89,7 +89,7 @@ ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings - (#AllT [#None "Bindings" "k" + (#AllT [(#Some #Nil) "lux;Bindings" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;counter" Int] (#Cons [["lux;mappings" (#AppT [List @@ -104,7 +104,7 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT [#None "Env" "k" + (#AllT [(#Some #Nil) "lux;Env" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;name" Text] (#Cons [["lux;inner-closures" Int] @@ -122,7 +122,7 @@ ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (_lux_def Meta - (#AllT [#None "Meta" "m" + (#AllT [(#Some #Nil) "lux;Meta" "m" (#AllT [#None "" "v" (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") (#Cons [(#BoundT "v") @@ -143,12 +143,12 @@ ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) (_lux_def Syntax' (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") + (#AppT [(#BoundT "lux;Syntax'") (#BoundT "w")])]) Syntax (_lux_case (#AppT [List Syntax]) SyntaxList - (#AllT [#None "Syntax'" "w" + (#AllT [(#Some #Nil) "lux;Syntax'" "w" (#VariantT (#Cons [["lux;BoolS" Bool] (#Cons [["lux;IntS" Int] (#Cons [["lux;RealS" Real] @@ -178,7 +178,7 @@ ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT [#None "_" "l" + (#AllT [(#Some #Nil) "lux;Either" "l" (#AllT [#None "" "r" (#VariantT (#Cons [["lux;Left" (#BoundT "l")] (#Cons [["lux;Right" (#BoundT "r")] @@ -188,7 +188,7 @@ ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [#None "StateE" "s" + (#AllT [(#Some #Nil) "lux;StateE" "s" (#AllT [#None "" "a" (#LambdaT [(#BoundT "s") (#AppT [(#AppT [Either Text]) @@ -218,7 +218,7 @@ ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [#None "DefData'" "" + (#AllT [(#Some #Nil) "lux;DefData'" "" (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] (#Cons [["lux;ValueD" Type] (#Cons [["lux;MacroD" (#BoundT "")] @@ -234,20 +234,20 @@ #Nil])]))) (_lux_export LuxVar) -## (deftype #rec CompilerState +## (deftype #rec Compiler ## (& #source Reader -## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))) +## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) ## #module-aliases (List Void) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) -(_lux_def CompilerState - (#AppT [(#AllT [#None "CompilerState" "" +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") + (#AppT [(#AppT [StateE (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) SyntaxList])])]) #Nil])])) @@ -261,13 +261,13 @@ (#Cons [["lux;seed" Int] #Nil])])])])])])]))]) Void])) -(_lux_export CompilerState) +(_lux_export Compiler) ## (deftype Macro -## (-> (List Syntax) (StateE CompilerState (List Syntax)))) +## (-> (List Syntax) (StateE Compiler (List Syntax)))) (_lux_def Macro (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) + (#AppT [(#AppT [StateE Compiler]) SyntaxList])])) (_lux_export Macro) @@ -284,15 +284,15 @@ ## (def (return x) ## (All [a] -## (-> a CompilerState -## (Either Text (, CompilerState a)))) +## (-> a Compiler +## (Either Text (, Compiler a)))) ## ...) (_lux_def return - (_lux_: (#AllT [#None "" "a" + (_lux_: (#AllT [(#Some #Nil) "" "a" (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState + (#LambdaT [Compiler (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState + (#TupleT (#Cons [Compiler (#Cons [(#BoundT "a") #Nil])]))])])])]) (_lux_lambda _ val @@ -301,15 +301,15 @@ ## (def (fail msg) ## (All [a] -## (-> Text CompilerState -## (Either Text (, CompilerState a)))) +## (-> Text Compiler +## (Either Text (, Compiler a)))) ## ...) (_lux_def fail - (_lux_: (#AllT [#None "" "a" + (_lux_: (#AllT [(#Some #Nil) "" "a" (#LambdaT [Text - (#LambdaT [CompilerState + (#LambdaT [Compiler (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState + (#TupleT (#Cons [Compiler (#Cons [(#BoundT "a") #Nil])]))])])])]) (_lux_lambda _ msg @@ -911,11 +911,11 @@ (fail "Wrong syntax for if"))) ## (deftype (Lux a) -## (-> CompilerState (Either Text (, CompilerState a)))) +## (-> Compiler (Either Text (, Compiler a)))) (def__ #export Lux Type (All' [a] - (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' a))))))) + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1246,7 +1246,7 @@ (replace-syntax replacements body) (reverse targs))] (return (_lux_: SyntaxList - (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) #None (fail "'All' arguments must be symbols.")) @@ -1281,7 +1281,7 @@ (#Right [state module-name])))) (def__ (find-macro' modules current-module module name) - (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) + (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) Text Text Text ($' Maybe Macro)) (do Maybe:Monad @@ -1949,7 +1949,7 @@ #seed seed} (case (get "lux" modules) (#Some lux) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax)))))) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] -- cgit v1.2.3 From e86b31726a19b0706f3618467775ba8ce6030393 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 24 May 2015 18:55:08 -0400 Subject: - Cleaned-up a few things in lux.lux - Replace most instances of "=" with ".equals". - Added an optimization to lux.type/type= that drastically speeds-up type comparisons. --- source/lux.lux | 210 +++++++++++++++++++++++++++------------------------------ 1 file changed, 100 insertions(+), 110 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 9b5601eb4..ac47e81eb 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -360,7 +360,7 @@ (fail "Wrong syntax for let'"))))) (_lux_declare-macro let') -(_lux_def lambda_ +(_lux_def lambda' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens @@ -374,7 +374,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -390,7 +390,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -398,11 +398,11 @@ _ (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda_) +(_lux_declare-macro lambda') -(_lux_def def_ +(_lux_def def' (_lux_: Macro - (lambda_ [tokens] + (lambda' [tokens] (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -412,7 +412,7 @@ (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) @@ -440,7 +440,7 @@ (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) @@ -462,14 +462,14 @@ _ (fail "Wrong syntax for def") )))) -(_lux_declare-macro def_) +(_lux_declare-macro def') -(def_ #export (defmacro tokens) +(def' #export (defmacro tokens) Macro (_lux_case tokens (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) (#Cons [body @@ -480,7 +480,7 @@ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) (#Cons [($tag ["" "export"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) @@ -575,7 +575,7 @@ _ (fail "Wrong syntax for $'"))) -(def_ #export (fold f init xs) +(def' #export (fold f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -588,19 +588,19 @@ (#Cons [x xs']) (fold f (f init x) xs'))) -(def_ #export (reverse list) +(def' #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) (fold (_lux_: (All' [a] (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda_ [tail head] + (lambda' [tail head] (#Cons [head tail]))) #Nil list)) (defmacro #export (list xs) (return (_lux_: SyntaxList - (#Cons [(fold (lambda_ [tail head] + (#Cons [(fold (lambda' [tail head] (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) #Nil])])))) @@ -612,7 +612,7 @@ (_lux_case (reverse xs) (#Cons [last init]) (return (_lux_: SyntaxList - (list (fold (lambda_ [tail head] + (list (fold (lambda' [tail head] (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list head tail))))))) last @@ -640,7 +640,7 @@ (list ($form (list ($symbol ["" "_lux_lambda"]) ($symbol name) harg - (fold (lambda_ [body' arg] + (fold (lambda' [body' arg] ($form (list ($symbol ["" "_lux_lambda"]) ($symbol ["" ""]) arg @@ -651,7 +651,7 @@ _ (fail "Wrong syntax for lambda")))) -(defmacro (def__ tokens) +(defmacro (def'' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -698,7 +698,7 @@ (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 @@ -728,7 +728,7 @@ _ (fail "Wrong syntax for let"))) -(def__ #export (map f xs) +(def'' #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -738,7 +738,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def__ #export (any? p xs) +(def'' #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs @@ -750,7 +750,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])]))]) @@ -759,13 +759,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 @@ -775,7 +775,7 @@ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def__ (list:++ xs ys) +(def'' (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (_lux_case xs (#Cons [x xs']) @@ -795,7 +795,7 @@ _ (fail "Wrong syntax for $"))) -(def__ (splice untemplate tag elems) +(def'' (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_lux_case (any? spliced? elems) true @@ -818,7 +818,7 @@ false (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) -(def__ (untemplate subst token) +(def'' (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token (#Meta [_ (#BoolS value)]) @@ -912,7 +912,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))))))) @@ -922,7 +922,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))))] @@ -930,7 +930,7 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def__ Maybe:Monad +(def'' Maybe:Monad ($' Monad Maybe) {#lux;return (lambda return [x] @@ -942,7 +942,7 @@ #None #None (#Some a) (f a)))}) -(def__ Lux:Monad +(def'' Lux:Monad ($' Monad Lux) {#lux;return (lambda [x] @@ -1009,7 +1009,7 @@ _ (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] @@ -1029,13 +1029,13 @@ (;return (_lux_: List (#Cons [y ys])))) ))) -(def__ #export (. f g) +(def'' #export (. f g) (All' [a b c] (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) (lambda [x] (f (g x)))) -(def__ (get-ident x) +(def'' (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1044,7 +1044,7 @@ _ #None)) -(def__ (tuple->list tuple) +(def'' (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple (#Meta [_ (#TupleS members)]) @@ -1053,11 +1053,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]) @@ -1067,12 +1067,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 @@ -1083,7 +1083,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])]) @@ -1110,7 +1110,7 @@ _ 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 @@ -1140,7 +1140,7 @@ (fail "Wrong syntax for do-template"))) (do-template [ ] - [(def__ #export ( x y) + [(def'' #export ( x y) (-> Bool) ( x y))] @@ -1153,7 +1153,7 @@ ) (do-template [ ] - [(def__ #export ( x y) + [(def'' #export ( x y) (-> ) ( x y))] @@ -1169,29 +1169,29 @@ [real:% _jvm_drem Real] ) -(def__ (multiple? div n) +(def'' (multiple? div n) (-> Int Int Bool) (int:= 0 (int:% n div))) -(def__ #export (length list) +(def'' #export (length list) (-> List Int) (fold (lambda [acc _] (int:+ 1 acc)) 0 list)) -(def__ #export (not x) +(def'' #export (not x) (-> Bool Bool) (if x false true)) -(def__ #export (text:++ x y) +(def'' #export (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))) -(def__ (replace-syntax reps syntax) +(def'' (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax (#Meta [_ (#SymbolS ["" name])]) @@ -1255,7 +1255,7 @@ (fail "Wrong syntax for All")) )) -(def__ (get k plist) +(def'' (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (_lux_case plist @@ -1267,7 +1267,7 @@ #Nil #None)) -(def__ #export (get-module-name state) +(def'' #export (get-module-name state) ($' Lux Text) (_lux_case state {#source source #modules modules #module-aliases module-aliases @@ -1280,7 +1280,7 @@ (#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 ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) Text Text Text ($' Maybe Macro)) @@ -1301,7 +1301,7 @@ _ #None))) -(def__ #export (find-macro ident) +(def'' #export (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux:Monad [current-module get-module-name] @@ -1313,12 +1313,12 @@ #seed seed} (#Right [state (find-macro' modules current-module module name)])))))) -(def__ (list:join xs) +(def'' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) -## (def__ #export (normalize ident) +## (def'' #export (normalize ident) ## (-> Ident ($' Lux Ident)) ## (_lux_case ident ## ["" name] @@ -1328,7 +1328,7 @@ ## _ ## (return ident))) -(def__ #export (normalize ident state) +(def'' #export (normalize ident state) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] @@ -1387,11 +1387,11 @@ (;return (_lux_: SyntaxList (list (`' (#;RecordT (;list (~@ pairs)))))))))) -(def__ #export (->text x) +(def'' #export (->text x) (-> (^ java.lang.Object) Text) (_jvm_invokevirtual java.lang.Object toString [] x [])) -(def__ #export (interpose sep xs) +(def'' #export (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1404,7 +1404,7 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def__ #export (syntax:show syntax) +(def'' #export (syntax:show syntax) (-> Syntax Text) (_lux_case syntax (#Meta [_ (#BoolS value)]) @@ -1446,7 +1446,7 @@ "}") )) -(def__ #export (macro-expand syntax) +(def'' #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) @@ -1479,7 +1479,7 @@ _ (return (_lux_: SyntaxList (list syntax))))) -(def__ (walk-type type) +(def'' (walk-type type) (-> Syntax Syntax) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) @@ -1525,8 +1525,8 @@ (defmacro #export (:! tokens) (_lux_case tokens (#Cons [type (#Cons [value #Nil])]) - (return (_lux_: SyntaxList - (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) + (return (: (List Syntax) + (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) _ (fail "Wrong syntax for :!"))) @@ -1562,9 +1562,9 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (;type` (~ type')))) - with-export)))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export)))) #None (fail "Wrong syntax for deftype")) @@ -1636,11 +1636,11 @@ #None body'))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for def")))) @@ -1702,10 +1702,10 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (_lux_: SyntaxList - (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] (list pattern body))) - (list:join patterns'))))))) + (;return (: (List Syntax) + (list:join (map (: (-> Syntax (List Syntax)) + (lambda [pattern] (list pattern body))) + (list:join patterns'))))))) _ (fail "Wrong syntax for \\or"))) @@ -1804,11 +1804,11 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1828,8 +1828,8 @@ _ (fail "Structures require defined members!")))) tokens')] - (;return (_lux_: SyntaxList - (list ($record members)))))) + (;return (: (List Syntax) + (list ($record members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1858,11 +1858,11 @@ _ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (_lux_: SyntaxList - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1957,11 +1957,11 @@ (list name) (list))))) lux)] - (#Right [state (_lux_: SyntaxList - (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) - (list:join to-alias)))])) + (#Right [state (: (List Syntax) + (map (: (-> Text Syntax) + (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) + (list:join to-alias)))])) #None (#Left "Uh, oh... The universe is not working properly...")) @@ -2065,33 +2065,23 @@ [($tag [module name]) ($symbol ["" name])]))) slots)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (_lux_: SyntaxList - (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (_lux_: SyntaxList - (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) (~ body))))))]))) + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body))))))]))) _ (#Left "Wrong syntax for defsig"))) -(defmacro #export (when tokens) - (case tokens - (\ (list test body)) - (return (_lux_: SyntaxList - (list (` (if (~ test) - (#Some (~ body)) - #None))))) - - _ - (fail "Wrong syntax for when"))) - (def #export (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) -- cgit v1.2.3 From 639c9385219e143fd7a6161c57fda34293b81055 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 26 May 2015 22:35:58 -0400 Subject: - Now using an in-memory class-loader. --- source/lux.lux | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index ac47e81eb..ac28bf372 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -206,11 +206,13 @@ ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader))) +## #loader (^ java.net.URLClassLoader) +## #classes (^ clojure.lang.Atom))) (_lux_def HostState (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - #Nil])]))) + (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] + #Nil])])]))) ## (deftype (DefData' m) ## (| #TypeD -- cgit v1.2.3 From 5e45ec0419293fdde30cc9e3f0326e44ddd7442a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 27 May 2015 00:57:57 -0400 Subject: - _jvm_program now relies on the (IO (,)) type. - The command-line params argument in jvm_program is now transformed from a String array into (List Text). --- source/lux.lux | 13 +++++++------ source/program.lux | 5 +---- 2 files changed, 8 insertions(+), 10 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index ac28bf372..bce5c421a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1970,12 +1970,14 @@ )) (def #export (print x) - (-> Text (,)) - (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [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 (,)) + (-> Text (IO (,))) (print (text:++ x "\n"))) (def #export (some f xs) @@ -2065,8 +2067,7 @@ (let [[sname stype] slot [module name] (split-slot sname)] [($tag [module name]) ($symbol ["" name])]))) - slots)) - _ (println (text:++ "Using pattern: " (syntax:show pattern)))] + slots))] (#Right [state (: (List Syntax) (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) diff --git a/source/program.lux b/source/program.lux index cefec07d4..364c57d89 100644 --- a/source/program.lux +++ b/source/program.lux @@ -12,7 +12,4 @@ (filter p xs')))) (_jvm_program _ - (exec (println "Hello, world!") - (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) - (println (->text (using Int:Ord - (< 5 10)))))) + (println "Hello, world!")) -- cgit v1.2.3 From 0952d5906d90f305e0604447d6b292204ba53711 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 31 May 2015 00:45:35 -0400 Subject: - Finished _jvm-interface_ & _jvm-class_. - The version of the compiler is now stored as a field in the compiled definitions. --- source/lux.lux | 207 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 114 insertions(+), 93 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index bce5c421a..2e5752592 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -7,9 +7,17 @@ ## You must not remove this notice, or any other, from this software. ## First things first, must define functions -(_jvm_interface Function - (: (-> [java.lang.Object] java.lang.Object) - apply)) +(_jvm_interface "lux.Function" [] + (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) ## Basic types (_lux_def Bool (#DataT "java.lang.Boolean")) @@ -577,7 +585,7 @@ _ (fail "Wrong syntax for $'"))) -(def' #export (fold f init xs) +(def' #export (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -588,37 +596,50 @@ init (#Cons [x xs']) - (fold f (f init 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) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (fold (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda' [tail head] - (#Cons [head tail]))) - #Nil - list)) + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda' [tail head] + (#Cons [head tail]))) + #Nil + list)) (defmacro #export (list xs) (return (_lux_: SyntaxList - (#Cons [(fold (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)) + (#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])))) (defmacro #export (list& xs) (_lux_case (reverse xs) (#Cons [last init]) (return (_lux_: SyntaxList - (list (fold (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init)))) + (list (foldL (lambda' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init)))) _ (fail "Wrong syntax for list&"))) @@ -642,13 +663,13 @@ (list ($form (list ($symbol ["" "_lux_lambda"]) ($symbol name) harg - (fold (lambda' [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs)))))))) + (foldL (lambda' [body' arg] + ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs)))))))) _ (fail "Wrong syntax for lambda")))) @@ -714,18 +735,18 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) (return (_lux_: SyntaxList - (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) - body - (fold (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda [tail head] (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) + (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + body + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda [tail head] (#Cons [head tail]))) + #Nil + (as-pairs bindings)))))) _ (fail "Wrong syntax for let"))) @@ -790,9 +811,9 @@ (_lux_case tokens (#Cons [op (#Cons [init args])]) (return (_lux_: SyntaxList - (list (fold (lambda [a1 a2] ($form (list op a1 a2))) - init - args)))) + (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) + init + args)))) _ (fail "Wrong syntax for $"))) @@ -887,16 +908,16 @@ (_lux_case tokens (#Cons [init apps]) (return (_lux_: SyntaxList - (list (fold (_lux_: (->' Syntax Syntax Syntax) - (lambda [acc app] - (_lux_case app - (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [acc app] + (_lux_case app + (#Meta [_ (#FormS parts)]) + ($form (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) + _ + (`' ((~ app) (~ acc)))))) + init + apps)))) _ (fail "Wrong syntax for |>"))) @@ -974,10 +995,10 @@ (_lux_case (reverse tokens) (#Cons [output inputs]) (return (_lux_: SyntaxList - (list (fold (_lux_: (->' Syntax Syntax Syntax) - (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) + output + inputs)))) _ (fail "Wrong syntax for ->"))) @@ -989,20 +1010,20 @@ (defmacro (do tokens) (_lux_case tokens (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (fold (_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)))] + (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 (_lux_: SyntaxList (list (`' (_lux_case (~ monad) {#;return ;return #;bind ;bind} @@ -1177,7 +1198,7 @@ (def'' #export (length list) (-> List Int) - (fold (lambda [acc _] (int:+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) (def'' #export (not x) (-> Bool Bool) @@ -1242,11 +1263,11 @@ (let [replacements (map (_lux_: (-> Text (, Text Syntax)) (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) (list& self-ident idents)) - body' (fold (_lux_: (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) - (replace-syntax replacements body) - (reverse targs))] + body' (foldL (_lux_: (-> Syntax Text Syntax) + (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + (replace-syntax replacements body) + (reverse targs))] (return (_lux_: SyntaxList (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) @@ -1318,7 +1339,7 @@ (def'' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) - (fold list:++ #Nil xs)) + (foldL list:++ #Nil xs)) ## (def'' #export (normalize ident) ## (-> Ident ($' Lux Ident)) @@ -1431,10 +1452,10 @@ (text:++ "#" (ident->text ident)) (#Meta [_ (#TupleS members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]") (#Meta [_ (#FormS members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")") (#Meta [_ (#RecordS slots)]) ($ text:++ "{" @@ -1444,7 +1465,7 @@ (let [[k v] slot] ($ text:++ (syntax:show k) " " (syntax:show v)))))) (interpose " ") - (fold text:++ "")) + (foldL text:++ "")) "}") )) @@ -1491,10 +1512,10 @@ ($tuple (map walk-type members)) (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (fold (_lux_: (-> Syntax Syntax Syntax) - (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) - (walk-type type-fn) - (map walk-type args)) + (foldL (_lux_: (-> Syntax Syntax Syntax) + (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) + (walk-type type-fn) + (map walk-type args)) _ type)) @@ -1590,10 +1611,10 @@ (#Cons [value actions]) (let [dummy ($symbol ["" ""])] (return (_lux_: SyntaxList - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) - value - actions))))) + (list (foldL (: (-> Syntax Syntax Syntax) + (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions))))) _ (fail "Wrong syntax for exec"))) @@ -1914,10 +1935,10 @@ (case (reverse tokens) (\ (list& last init)) (return (: (List Syntax) - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] (` ))) - last - init)))) + (list (foldL (: (-> Syntax Syntax Syntax) + (lambda [post pre] (` ))) + last + init)))) _ (fail )))] -- cgit v1.2.3 From 81e1a4f10ad7aa7cfd76f9877e5e7deacb2d441e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 9 Jun 2015 22:37:56 -0400 Subject: - Put definition metadata into the generated .class files. --- source/lux.lux | 29 ++++++----------------------- 1 file changed, 6 insertions(+), 23 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 2e5752592..2a4cc8660 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1341,33 +1341,16 @@ (-> ($' List ($' List a)) ($' List a))) (foldL list:++ #Nil xs)) -## (def'' #export (normalize ident) -## (-> Ident ($' Lux Ident)) -## (_lux_case ident -## ["" name] -## (do Lux:Monad -## [module-name get-module-name] -## (;return (: Ident [module-name name]))) - -## _ -## (return ident))) -(def'' #export (normalize ident state) +(def'' #export (normalize ident) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] - (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (_lux_case (reverse envs) - #Nil - (#Left "Can't normalize Ident without a global environment.") - - (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) - (#Right [state [prefix name]]))) - + (do Lux:Monad + [module-name get-module-name] + (;return (_lux_: Ident [module-name name]))) + _ - (#Right [state ident]))) + (return ident))) (defmacro #export (| tokens) (do Lux:Monad -- cgit v1.2.3 From c6a120dd8324a306190b593ff1541046e1963e2d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 10 Jun 2015 00:41:02 -0400 Subject: - Reimplemented module-aliasing. --- source/lux.lux | 61 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 35 insertions(+), 26 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 2a4cc8660..10abcb88a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -244,10 +244,24 @@ #Nil])]))) (_lux_export LuxVar) +## (deftype (Module Compiler) +## (& #aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) +(_lux_def Module + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#RecordT (#Cons [["lux;aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + SyntaxList])])]) + #Nil])])) + #Nil])]))])] + #Nil])]))])) +(_lux_export Module) + ## (deftype #rec Compiler ## (& #source Reader -## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) -## #module-aliases (List Void) +## #modules (List (, Text (Module Compiler))) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) @@ -255,21 +269,14 @@ (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "lux;Compiler") - (#BoundT "")])]) - SyntaxList])])]) - #Nil])])) - #Nil])]))]) + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) #Nil])]))])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - #Nil])])])])])])]))]) + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + #Nil])])])])])]))]) Void])) (_lux_export Compiler) @@ -1293,7 +1300,7 @@ (def'' #export (get-module-name state) ($' Lux Text) (_lux_case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (_lux_case (reverse envs) @@ -1304,12 +1311,13 @@ (#Right [state module-name])))) (def'' (find-macro' modules current-module module name) - (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) + (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) (do Maybe:Monad - [bindings (get module modules) - gdef (get name bindings)] + [$module (get module modules) + gdef (let [{#aliases _ #defs bindings} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] (if exported? @@ -1331,7 +1339,7 @@ (let [[module name] ident] (lambda [state] (_lux_case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (#Right [state (find-macro' modules current-module module name)])))))) @@ -1741,10 +1749,10 @@ (def #export (gensym prefix state) (-> Text (Lux Syntax)) (case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} - (#Right [{#source source #modules modules #module-aliases module-aliases + (#Right [{#source source #modules modules #envs envs #types types #host host #seed (inc seed)} ($symbol ["__gensym__" (int:show seed)])]))) @@ -1950,7 +1958,7 @@ (defmacro #export (lux tokens state) (case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (case (get "lux" modules) @@ -1962,7 +1970,8 @@ (if export? (list name) (list))))) - lux)] + (let [{#aliases _ #defs defs} lux] + defs))] (#Right [state (: (List Syntax) (map (: (-> Text Syntax) (lambda [name] @@ -2044,7 +2053,7 @@ (#Meta [_ (#SymbolS vname)]) (let [vname' (ident->text vname)] (case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) -- cgit v1.2.3 From 082ef348efef7c4f1941c48f94b58e22fea724a4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 12 Jun 2015 08:04:59 -0400 Subject: - Added imports. - Now storing information about definitions & imports inside the .class files. --- source/lux.lux | 42 ++++++++++++++++++++++++------------------ 1 file changed, 24 insertions(+), 18 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 10abcb88a..07b245a5d 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -245,26 +245,31 @@ (_lux_export LuxVar) ## (deftype (Module Compiler) -## (& #aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) +## (& #module-aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #imports (List Text) +## )) (_lux_def Module (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList (#AppT [(#AppT [StateE (#BoundT "Compiler")]) SyntaxList])])]) #Nil])])) #Nil])]))])] - #Nil])]))])) + (#Cons [["lux;imports" (#AppT [List Text])] + #Nil])])]))])) (_lux_export Module) ## (deftype #rec Compiler -## (& #source Reader -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState)) +## (& #source Reader +## #modules (List (, Text (Module Compiler))) +## #envs (List (Env Text (, LuxVar Type))) +## #types (Bindings Int Type) +## #host HostState +## #seed Int +## #seen-sources (List Text))) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] @@ -276,7 +281,8 @@ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] (#Cons [["lux;host" HostState] (#Cons [["lux;seed" Int] - #Nil])])])])])]))]) + (#Cons [["lux;seen-sources" (#AppT [List Text])] + #Nil])])])])])])]))]) Void])) (_lux_export Compiler) @@ -1302,7 +1308,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (_lux_case (reverse envs) #Nil (#Left "Can't get the module name without a module!") @@ -1316,7 +1322,7 @@ ($' Maybe Macro)) (do Maybe:Monad [$module (get module modules) - gdef (let [{#aliases _ #defs bindings} (_lux_: ($' Module Compiler) $module)] + gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] @@ -1341,7 +1347,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (#Right [state (find-macro' modules current-module module name)])))))) (def'' (list:join xs) @@ -1751,10 +1757,10 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (#Right [{#source source #modules modules #envs envs #types types #host host - #seed (inc seed)} + #seed (inc seed) #seen-sources seen-sources} ($symbol ["__gensym__" (int:show seed)])]))) (def #export (macro-expand-1 token) @@ -1960,7 +1966,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (case (get "lux" modules) (#Some lux) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) @@ -1970,7 +1976,7 @@ (if export? (list name) (list))))) - (let [{#aliases _ #defs defs} lux] + (let [{#module-aliases _ #defs defs #imports _} lux] defs))] (#Right [state (: (List Syntax) (map (: (-> Text Syntax) @@ -2055,7 +2061,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env -- cgit v1.2.3 From 5e9e876131901204dd34ce1548a4df3cb6cba95f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 20 Jun 2015 20:19:02 -0400 Subject: - The directory for source-code is now named "input". - Implemented module-caching to avoid the waiting too much during program compilation. --- source/lux.lux | 2169 ---------------------------------------------------- source/program.lux | 15 - 2 files changed, 2184 deletions(-) delete mode 100644 source/lux.lux delete mode 100644 source/program.lux (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux deleted file mode 100644 index 07b245a5d..000000000 --- a/source/lux.lux +++ /dev/null @@ -1,2169 +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. - -## First things first, must define functions -(_jvm_interface "lux.Function" [] - (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) - -## Basic types -(_lux_def Bool (#DataT "java.lang.Boolean")) -(_lux_export Bool) - -(_lux_def Int (#DataT "java.lang.Long")) -(_lux_export Int) - -(_lux_def Real (#DataT "java.lang.Double")) -(_lux_export Real) - -(_lux_def Char (#DataT "java.lang.Character")) -(_lux_export Char) - -(_lux_def Text (#DataT "java.lang.String")) -(_lux_export Text) - -(_lux_def Void (#VariantT #Nil)) -(_lux_export Void) - -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) -(_lux_export Ident) - -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) -(_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) -(_lux_export List) - -## (deftype (Maybe a) -## (| #None -## (#Some a))) -(_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) -(_lux_export Maybe) - -## (deftype #rec Type -## (| (#DataT Text) -## (#TupleT (List Type)) -## (#VariantT (List (, Text Type))) -## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) -## (#BoundT Text) -## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) -(_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) -(_lux_export Type) - -## (deftype (Bindings k v) -## (& #counter Int -## #mappings (List (, k v)))) -(_lux_def Bindings - (#AllT [(#Some #Nil) "lux;Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) - -## (deftype (Env k v) -## (& #name Text -## #inner-closures Int -## #locals (Bindings k v) -## #closure (Bindings k v))) -(_lux_def Env - (#AllT [(#Some #Nil) "lux;Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) - -## (deftype Cursor -## (, Text Int Int)) -(_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) - -## (deftype (Meta m v) -## (| (#Meta (, m v)))) -(_lux_def Meta - (#AllT [(#Some #Nil) "lux;Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) -(_lux_export Meta) - -## (deftype (Syntax' w) -## (| (#BoolS Bool) -## (#IntS Int) -## (#RealS Real) -## (#CharS Char) -## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) -## (#FormS (List (w (Syntax' w)))) -## (#TupleS (List (w (Syntax' w)))) -## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(_lux_def Syntax' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;Syntax'") - (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [(#Some #Nil) "lux;Syntax'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(_lux_export Syntax') - -## (deftype Syntax -## (Meta Cursor (Syntax' (Meta Cursor)))) -(_lux_def Syntax - (_lux_case (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(_lux_export Syntax) - -(_lux_def SyntaxList (#AppT [List Syntax])) - -## (deftype (Either l r) -## (| (#Left l) -## (#Right r))) -(_lux_def Either - (#AllT [(#Some #Nil) "lux;Either" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) -(_lux_export Either) - -## (deftype (StateE s a) -## (-> s (Either Text (, s a)))) -(_lux_def StateE - (#AllT [(#Some #Nil) "lux;StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) - -## (deftype Reader -## (List (Meta Cursor Text))) -(_lux_def Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) -(_lux_export Reader) - -## (deftype HostState -## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #classes (^ clojure.lang.Atom))) -(_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] - #Nil])])]))) - -## (deftype (DefData' m) -## (| #TypeD -## (#ValueD Type) -## (#MacroD m) -## (#AliasD Ident))) -(_lux_def DefData' - (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) - -## (deftype LuxVar -## (| (#Local Int) -## (#Global Ident))) -(_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) -(_lux_export LuxVar) - -## (deftype (Module Compiler) -## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) -## #imports (List Text) -## )) -(_lux_def Module - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] - (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - SyntaxList])])]) - #Nil])])) - #Nil])]))])] - (#Cons [["lux;imports" (#AppT [List Text])] - #Nil])])]))])) -(_lux_export Module) - -## (deftype #rec Compiler -## (& #source Reader -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState -## #seed Int -## #seen-sources (List Text))) -(_lux_def Compiler - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - (#Cons [["lux;seen-sources" (#AppT [List Text])] - #Nil])])])])])])]))]) - Void])) -(_lux_export Compiler) - -## (deftype Macro -## (-> (List Syntax) (StateE Compiler (List Syntax)))) -(_lux_def Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE Compiler]) - SyntaxList])])) -(_lux_export Macro) - -## Base functions & macros -## (def (_meta data) -## (-> (Syntax' (Meta Cursor)) Syntax) -## (#Meta [["" -1 -1] data])) -(_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (_lux_lambda _ data - (#Meta [["" -1 -1] data])))) - -## (def (return x) -## (All [a] -## (-> a Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def return - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right [state val]))))) - -## (def (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def fail - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [Text - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) - -(_lux_def $text - (_lux_: (#LambdaT [Text Syntax]) - (_lux_lambda _ text - (_meta (#TextS text))))) - -(_lux_def $symbol - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) - -(_lux_def $tag - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#TagS ident))))) - -(_lux_def $form - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) - -(_lux_def $tuple - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) - -(_lux_def $record - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (_lux_lambda _ tokens - (_meta (#RecordS tokens))))) - -(_lux_def let' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil]))) - - _ - (fail "Wrong syntax for let'"))))) -(_lux_declare-macro let') - -(_lux_def lambda' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) - - (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) - - _ - (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda') - -(_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 (_lux_: SyntaxList - (#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 (_lux_: SyntaxList - (#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 (_lux_: SyntaxList - (#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 (_lux_: SyntaxList - (#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') - -(def' #export (defmacro tokens) - Macro - (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#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])])) - #Nil])]))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#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])])) - #Nil])]))) - - _ - (fail "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -(defmacro #export (comment tokens) - (return (_lux_: SyntaxList #Nil))) - -(defmacro (->' tokens) - (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil]))) - - (#Cons [input (#Cons [output others])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil]))) - - _ - (fail "Wrong syntax for ->'"))) - -(defmacro (All' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [body - #Nil]))) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil]))) - - _ - (fail "Wrong syntax for All'"))) - -(defmacro (B' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil]))) - - _ - (fail "Wrong syntax for B'"))) - -(defmacro ($' tokens) - (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) - - (#Cons [x (#Cons [y xs])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil]))) - - _ - (fail "Wrong syntax for $'"))) - -(def' #export (foldL f init xs) - (All' [a b] - (->' (->' (B' a) (B' b) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) - (_lux_case xs - #Nil - init - - (#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) - (All' [a] - (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda' [tail head] - (#Cons [head tail]))) - #Nil - list)) - -(defmacro #export (list xs) - (return (_lux_: SyntaxList - (#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])))) - -(defmacro #export (list& xs) - (_lux_case (reverse xs) - (#Cons [last init]) - (return (_lux_: SyntaxList - (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 (_lux_: SyntaxList - (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]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "_lux_export"]) name))))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - body)))) - ($form (list ($symbol ["" "_lux_export"]) name))))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body))))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) type body))))))) - - _ - (fail "Wrong syntax for def") - )) - -(def'' (as-pairs xs) - (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) - (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) - - _ - #Nil)) - -(defmacro #export (let tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) - body - (foldL (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda [tail head] (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) - - _ - (fail "Wrong syntax for let"))) - -(def'' #export (map f xs) - (All' [a b] - (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - -(def'' #export (any? p xs) - (All' [a] - (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) - (_lux_case xs - #Nil - false - - (#Cons [x xs']) - (_lux_case (p x) - true true - false (any? p xs')))) - -(def'' (spliced? token) - (->' Syntax Bool) - (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) - true - - _ - false)) - -(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) - (->' ($' List Syntax) Syntax) - (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) - - (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) - -(def'' (list:++ xs ys) - (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) - (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) - - #Nil - ys)) - -(defmacro #export ($ tokens) - (_lux_case tokens - (#Cons [op (#Cons [init args])]) - (return (_lux_: SyntaxList - (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) - init - args)))) - - _ - (fail "Wrong syntax for $"))) - -(def'' (splice untemplate tag elems) - (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (_lux_case (any? spliced? elems) - true - (let [elems' (map (_lux_: (->' Syntax Syntax) - (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - ($form (list ($symbol ["" "_lux_:"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) - 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))))))) - -(def'' (untemplate subst token) - (->' Text Syntax Syntax) - (_lux_case token - (#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))))) - - (#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))))) - - (#Meta [_ (#TextS value)]) - (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) - - (#Meta [_ (#TagS [module name])]) - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) - - (#Meta [_ (#SymbolS [module name])]) - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) - - (#Meta [_ (#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) - - (#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 subst k) (untemplate subst v)))))) - fields))))) - )) - -(defmacro (`' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (_lux_: SyntaxList - (list (untemplate "" template)))) - - _ - (fail "Wrong syntax for `'"))) - -(defmacro #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax Syntax Syntax) - (lambda [acc app] - (_lux_case app - (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) - - _ - (fail "Wrong syntax for |>"))) - -(defmacro #export (if tokens) - (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (_lux_: SyntaxList - (list (`' (_lux_case (~ test) - true (~ then) - false (~ else)))))) - - _ - (fail "Wrong syntax for if"))) - -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) -(def'' #export Lux - Type - (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) - -## (defsig (Monad m) -## (: (All [a] (-> a (m a))) -## return) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -(def'' Monad - Type - (All' [m] - (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] - ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))])))) - -(def'' Maybe:Monad - ($' Monad Maybe) - {#lux;return - (lambda return [x] - (#Some x)) - - #lux;bind - (lambda [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) - -(def'' Lux:Monad - ($' Monad Lux) - {#lux;return - (lambda [x] - (lambda [state] - (#Right [state x]))) - - #lux;bind - (lambda [f ma] - (lambda [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) - - (#Right [state' a]) - (f a state'))))}) - -(defmacro #export (^ tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (_lux_: SyntaxList - (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))) - - _ - (fail "Wrong syntax for ^"))) - -(defmacro #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax Syntax Syntax) - (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) - - _ - (fail "Wrong syntax for ->"))) - -(defmacro #export (, tokens) - (return (_lux_: SyntaxList - (list (`' (#;TupleT (;list (~@ tokens)))))))) - -(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 (_lux_: SyntaxList - (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))))) - - _ - (fail "Wrong syntax for do"))) - -(def'' (map% m f xs) - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All' [m a b] - (-> ($' Monad (B' m)) - (-> (B' a) ($' (B' m) (B' b))) - ($' List (B' a)) - ($' (B' m) ($' List (B' b))))) - (let [{#;return ;return #;bind _} m] - (_lux_case xs - #Nil - (;return (_lux_: List #Nil)) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (_lux_: List (#Cons [y ys])))) - ))) - -(def'' #export (. f g) - (All' [a b c] - (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) - (lambda [x] - (f (g x)))) - -(def'' (get-ident x) - (-> Syntax ($' Maybe Text)) - (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) - (#Some sname) - - _ - #None)) - -(def'' (tuple->list tuple) - (-> Syntax ($' Maybe ($' List Syntax))) - (_lux_case tuple - (#Meta [_ (#TupleS members)]) - (#Some members) - - _ - #None)) - -(def'' RepEnv - Type - ($' List (, Text Syntax))) - -(def'' (make-env xs ys) - (-> ($' List Text) ($' List Syntax) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) - - _ - #Nil)) - -(def'' (text:= x y) - (-> Text Text Bool) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y])) - -(def'' (get-rep key env) - (-> Text RepEnv ($' Maybe Syntax)) - (_lux_case env - #Nil - #None - - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) - -(def'' (apply-template env template) - (-> RepEnv Syntax Syntax) - (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) - (_lux_case (get-rep sname env) - (#Some subst) - subst - - _ - template) - - (#Meta [_ (#TupleS elems)]) - ($tuple (map (apply-template env) elems)) - - (#Meta [_ (#FormS elems)]) - ($form (map (apply-template env) elems)) - - (#Meta [_ (#RecordS members)]) - ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) - - _ - template)) - -(def'' (join-map f xs) - (All' [a b] - (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro #export (do-template tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(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)) - - _ - (fail "All the do-template bindigns must be symbols.")) - - _ - (fail "Wrong syntax for do-template"))) - -(do-template [ ] - [(def'' #export ( x y) - (-> Bool) - ( x y))] - - [int:= _jvm_leq Int] - [int:> _jvm_lgt Int] - [int:< _jvm_llt Int] - [real:= _jvm_deq Real] - [real:> _jvm_dgt Real] - [real:< _jvm_dlt Real] - ) - -(do-template [ ] - [(def'' #export ( x y) - (-> ) - ( x y))] - - [int:+ _jvm_ladd Int] - [int:- _jvm_lsub Int] - [int:* _jvm_lmul Int] - [int:/ _jvm_ldiv Int] - [int:% _jvm_lrem Int] - [real:+ _jvm_dadd Real] - [real:- _jvm_dsub Real] - [real:* _jvm_dmul Real] - [real:/ _jvm_ddiv Real] - [real:% _jvm_drem Real] - ) - -(def'' (multiple? div n) - (-> Int Int Bool) - (int:= 0 (int:% n div))) - -(def'' #export (length list) - (-> List Int) - (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) - -(def'' #export (not x) - (-> Bool Bool) - (if x false true)) - -(def'' #export (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] - x [y])) - -(def'' (ident->text ident) - (-> Ident Text) - (let [[module name] ident] - ($ text:++ module ";" name))) - -(def'' (replace-syntax reps syntax) - (-> RepEnv Syntax Syntax) - (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) - (_lux_case (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#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)]))) - slots))]) - - _ - syntax) - ) - -(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 (_lux_: SyntaxList - (list body))) - - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) - (list& self-ident idents)) - body' (foldL (_lux_: (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) - (replace-syntax replacements body) - (reverse targs))] - (return (_lux_: SyntaxList - (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) - -(def'' (get k plist) - (All [a] - (-> Text ($' List (, Text a)) ($' Maybe a))) - (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) - - #Nil - #None)) - -(def'' #export (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") - - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state 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))] - (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) - -(def'' #export (find-macro ident) - (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux:Monad - [current-module get-module-name] - (let [[module name] ident] - (lambda [state] - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (#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'' #export (normalize ident) - (-> Ident ($' Lux Ident)) - (_lux_case ident - ["" name] - (do Lux:Monad - [module-name get-module-name] - (;return (_lux_: Ident [module-name name]))) - - _ - (return ident))) - -(defmacro #export (| tokens) - (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 (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad - [ident (normalize ident)] - (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) - - _ - (fail "Wrong syntax for |")))) - tokens)] - (;return (_lux_: SyntaxList - (list (`' (#;VariantT (;list (~@ pairs))))))))) - -(defmacro #export (& tokens) - (if (not (multiple? 2 (length tokens))) - (fail "& expects an even number of arguments.") - (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 (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) - - _ - (fail "Wrong syntax for &")))) - (as-pairs tokens))] - (;return (_lux_: SyntaxList - (list (`' (#;RecordT (;list (~@ pairs)))))))))) - -(def'' #export (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual java.lang.Object toString [] x [])) - -(def'' #export (interpose sep xs) - (All [a] - (-> a ($' List a) ($' List a))) - (_lux_case xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#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) - (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux:Monad - [macro-name' (normalize macro-name) - ?macro (find-macro (_lux_: Ident macro-name'))] - (_lux_case (_lux_: ($' Maybe Macro) ?macro) - (#Some macro) - (do Lux:Monad - [expansion (macro args) - expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))] - (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion'))))) - - #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts'))))))))) - - (#Meta [_ (#FormS (#Cons [harg targs]))]) - (do Lux:Monad - [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))] - (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+)))))))) - - (#Meta [_ (#TupleS members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members'))))))) - - _ - (return (_lux_: SyntaxList (list syntax))))) - -(def'' (walk-type type) - (-> Syntax Syntax) - (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) - - (#Meta [_ (#TupleS members)]) - ($tuple (map walk-type members)) - - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (_lux_: (-> Syntax Syntax Syntax) - (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) - -(defmacro #export (type` tokens) - (_lux_case tokens - (#Cons [type #Nil]) - (do Lux:Monad - [type+ (macro-expand type)] - (_lux_case (_lux_: SyntaxList type+) - (#Cons [type' #Nil]) - (;return (_lux_: SyntaxList - (list (walk-type type')))) - - _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for type`"))) - -(defmacro #export (: tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (_lux_: SyntaxList - (list (`' (_lux_: (;type` (~ type)) (~ value)))))) - - _ - (fail "Wrong syntax for :"))) - -(defmacro #export (:! tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (: (List Syntax) - (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) - - _ - (fail "Wrong syntax for :!"))) - -(defmacro #export (deftype tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) - - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) - - _ - #None))] - (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)) - type' (: Syntax - (_lux_case args - #Nil - type - - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (: (List Syntax) - (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 (_lux_: SyntaxList - (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 ["" ""])] - (return (_lux_: SyntaxList - (list (foldL (: (-> Syntax Syntax Syntax) - (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'] - - _ - [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 - - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for def")))) - -(def (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) - -(defmacro #export (case tokens) - (_lux_case tokens - (#Cons [value branches]) - (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 (: (List Syntax) expansion)))] - (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions))))) - - _ - (;return (: (List (, Syntax Syntax)) (list branch))))))) - (as-pairs branches))] - (;return (_lux_: SyntaxList - (list (`' (_lux_case (~ value) - (~@ (|> (: (List (List (, Syntax Syntax))) expansions) - list:join (map rejoin-pair) list:join)))))))) - - _ - (fail "Wrong syntax for case"))) - -(defmacro #export (\ tokens) - (case tokens - (#Cons [body (#Cons [pattern #Nil])]) - (do Lux:Monad - [pattern+ (macro-expand pattern)] - (case (: (List Syntax) pattern+) - (#Cons [pattern' #Nil]) - (;return (: (List Syntax) - (list pattern' body))) - - _ - (fail "\\ can only expand to 1 pattern."))) - - _ - (fail "Wrong syntax for \\"))) - -(defmacro #export (\or tokens) - (case tokens - (#Cons [body patterns]) - (case patterns - #Nil - (fail "\\or can't have 0 patterns") - - _ - (do Lux:Monad - [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (: (List Syntax) - (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] (list pattern body))) - (list:join patterns'))))))) - - _ - (fail "Wrong syntax for \\or"))) - -(do-template [ ] - [(def #export (int:+ ))] - - [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] - (case tokens - (\ (list template)) - (;return (_lux_: SyntaxList - (list (untemplate module-name template)))) - - _ - (fail "Wrong syntax for `")))) - -(def #export (gensym prefix state) - (-> Text (Lux Syntax)) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (inc seed) #seen-sources seen-sources} - ($symbol ["__gensym__" (int:show seed)])]))) - -(def #export (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux:Monad - [token+ (macro-expand token)] - (case (: (List Syntax) token+) - (\ (list token')) - (;return token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(defmacro #export (sig tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) - members (map% Lux:Monad - (: (-> Syntax (Lux (, Ident Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) - (do Lux:Monad - [name' (normalize name)] - (;return (: (, Ident Syntax) [name' type]))) - - _ - (fail "Signatures require typed members!")))) - tokens')] - (;return (: (List Syntax) - (list (`' (#;RecordT (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)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) - - (\ (list& name sigs)) - (#Some [name #Nil sigs]) - - _ - #None))] - (case ?parts - (#Some [name args sigs]) - (let [sigs' (: Syntax - (case args - #Nil - (`' (;sig (~@ sigs))) - - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for defsig")))) - -(defmacro #export (struct tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) - members (map% Lux:Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [token] - (case token - (\ (#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!")))) - tokens')] - (;return (: (List Syntax) - (list ($record members)))))) - -(defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) - - (\ (list& name type defs)) - (#Some [name #Nil type defs]) - - _ - #None))] - (case ?parts - (#Some [name args type defs]) - (let [defs' (: Syntax - (case args - #Nil - (`' (;struct (~@ defs))) - - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (: (List Syntax) - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for defsig")))) - -(defsig #export (Eq a) - (: (-> a a Bool) - =)) - -(do-template [ ] - [(defstruct #export (Eq ) - (def (= x y) - ( x y)))] - - [Int:Eq Int _jvm_leq] - [Real:Eq Real _jvm_deq]) - -(def #export (id x) - (All [a] (-> a a)) - x) - -(defsig #export (Show a) - (: (-> a Text) - show)) - -(do-template [ ] - [(defstruct #export (Show ) - (def (show x) - ))] - - [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 [ ] - [(defmacro #export ( tokens) - (case (reverse tokens) - (\ (list& last init)) - (return (: (List Syntax) - (list (foldL (: (-> Syntax Syntax Syntax) - (lambda [post pre] (` ))) - last - init)))) - - _ - (fail )))] - - [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] - [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) - -(do-template [ ] - [(defstruct #export (Ord ) - (def (< x y) - ( x y)) - - (def (<= x y) - (or ( x y) - ( x y))) - - (def (> x y) - ( x y)) - - (def (>= x y) - (or ( x y) - ( 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) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (case (get "lux" modules) - (#Some lux) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (let [{#module-aliases _ #defs defs #imports _} lux] - defs))] - (#Right [state (: (List Syntax) - (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) - (list:join to-alias)))])) - - #None - (#Left "Uh, oh... The universe is not working properly...")) - )) - -(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 (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int int] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(def (split-slot slot) - (-> Text (, Text Text)) - (let [idx (index-of ";" slot) - module (substring2 0 idx slot) - name (substring1 (inc idx) slot)] - [module name])) - -(def (resolve-struct-type type) - (-> Type (Maybe Type)) - (case type - (#RecordT slots) - (#Some type) - - (#AppT [fun arg]) - (resolve-struct-type fun) - - (#AllT [_ _ _ body]) - (resolve-struct-type body) - - _ - #None)) - -(defmacro #export (using tokens state) - (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} - (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 Syntax) - (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) - - _ - (#Left "Can only \"use\" records.")))))) - - _ - (let [dummy ($symbol ["" ""])] - (#Right [state (: (List Syntax) - (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body))))))]))) - - _ - (#Left "Wrong syntax for defsig"))) - -(def #export (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 [[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)))) diff --git a/source/program.lux b/source/program.lux deleted file mode 100644 index 364c57d89..000000000 --- a/source/program.lux +++ /dev/null @@ -1,15 +0,0 @@ -(;lux) - -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (list) - - (#;Cons [x xs']) - (if (p x) - (list& x (filter p xs')) - (filter p xs')))) - -(_jvm_program _ - (println "Hello, world!")) -- cgit v1.2.3 From 4cd9b0c9242f1105e50ad9b42b7f6f5d074f14b4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Jul 2015 20:19:43 -0400 Subject: - The output directory is now being used as the cache. - "input" has been renamed as "source" and "output" has been renamed as "target". --- source/lux.lux | 2784 ++++++++++++++++++++++++++++++++++++++++ source/lux/codata/stream.lux | 133 ++ source/lux/control/comonad.lux | 54 + source/lux/control/functor.lux | 15 + source/lux/control/lazy.lux | 47 + source/lux/control/monad.lux | 99 ++ source/lux/control/monoid.lux | 24 + source/lux/data/bool.lux | 33 + source/lux/data/bounded.lux | 17 + source/lux/data/char.lux | 20 + source/lux/data/dict.lux | 83 ++ source/lux/data/either.lux | 46 + source/lux/data/eq.lux | 14 + source/lux/data/error.lux | 34 + source/lux/data/id.lux | 28 + source/lux/data/io.lux | 51 + source/lux/data/list.lux | 250 ++++ source/lux/data/maybe.lux | 42 + source/lux/data/number.lux | 119 ++ source/lux/data/ord.lux | 44 + source/lux/data/reader.lux | 33 + source/lux/data/show.lux | 14 + source/lux/data/state.lux | 35 + source/lux/data/text.lux | 146 +++ source/lux/data/writer.lux | 34 + source/lux/host/java.lux | 312 +++++ source/lux/math.lux | 60 + source/lux/meta/lux.lux | 287 +++++ source/lux/meta/macro.lux | 54 + source/lux/meta/syntax.lux | 262 ++++ source/program.lux | 48 + 31 files changed, 5222 insertions(+) create mode 100644 source/lux.lux create mode 100644 source/lux/codata/stream.lux create mode 100644 source/lux/control/comonad.lux create mode 100644 source/lux/control/functor.lux create mode 100644 source/lux/control/lazy.lux create mode 100644 source/lux/control/monad.lux create mode 100644 source/lux/control/monoid.lux create mode 100644 source/lux/data/bool.lux create mode 100644 source/lux/data/bounded.lux create mode 100644 source/lux/data/char.lux create mode 100644 source/lux/data/dict.lux create mode 100644 source/lux/data/either.lux create mode 100644 source/lux/data/eq.lux create mode 100644 source/lux/data/error.lux create mode 100644 source/lux/data/id.lux create mode 100644 source/lux/data/io.lux create mode 100644 source/lux/data/list.lux create mode 100644 source/lux/data/maybe.lux create mode 100644 source/lux/data/number.lux create mode 100644 source/lux/data/ord.lux create mode 100644 source/lux/data/reader.lux create mode 100644 source/lux/data/show.lux create mode 100644 source/lux/data/state.lux create mode 100644 source/lux/data/text.lux create mode 100644 source/lux/data/writer.lux create mode 100644 source/lux/host/java.lux create mode 100644 source/lux/math.lux create mode 100644 source/lux/meta/lux.lux create mode 100644 source/lux/meta/macro.lux create mode 100644 source/lux/meta/syntax.lux create mode 100644 source/program.lux (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux new file mode 100644 index 000000000..50f8f1af2 --- /dev/null +++ b/source/lux.lux @@ -0,0 +1,2784 @@ +## 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. + +## First things first, must define functions +(_jvm_interface "Function" [] + (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## Basic types +(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_export Bool) + +(_lux_def Int (#DataT "java.lang.Long")) +(_lux_export Int) + +(_lux_def Real (#DataT "java.lang.Double")) +(_lux_export Real) + +(_lux_def Char (#DataT "java.lang.Character")) +(_lux_export Char) + +(_lux_def Text (#DataT "java.lang.String")) +(_lux_export Text) + +(_lux_def Unit (#TupleT #Nil)) +(_lux_export Unit) + +(_lux_def Void (#VariantT #Nil)) +(_lux_export Void) + +(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_export Ident) + +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) +(_lux_def List + (#AllT [(#Some #Nil) "lux;List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) +(_lux_export List) + +## (deftype (Maybe a) +## (| #None +## (#Some a))) +(_lux_def Maybe + (#AllT [(#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) +(_lux_export Maybe) + +## (deftype #rec Type +## (| (#DataT Text) +## (#TupleT (List Type)) +## (#VariantT (List (, Text Type))) +## (#RecordT (List (, Text Type))) +## (#LambdaT (, Type Type)) +## (#BoundT Text) +## (#VarT Int) +## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) +## (#AppT (, Type Type)))) +(_lux_def Type + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [(#Some #Nil) "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) +(_lux_export Type) + +## (deftype (Bindings k v) +## (& #counter Int +## #mappings (List (, k v)))) +(_lux_def Bindings + (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) +(_lux_export Bindings) + +## (deftype (Env k v) +## (& #name Text +## #inner-closures Int +## #locals (Bindings k v) +## #closure (Bindings k v))) +(_lux_def Env + (#AllT [(#Some #Nil) "lux;Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) +(_lux_export Env) + +## (deftype Cursor +## (, Text Int Int)) +(_lux_def Cursor + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_export Cursor) + +## (deftype (Meta m v) +## (| (#Meta (, m v)))) +(_lux_def Meta + (#AllT [(#Some #Nil) "lux;Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) +(_lux_export Meta) + +## (deftype (Syntax' w) +## (| (#BoolS Bool) +## (#IntS Int) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS (, Text Text)) +## (#TagS (, Text Text)) +## (#FormS (List (w (Syntax' w)))) +## (#TupleS (List (w (Syntax' w)))) +## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) +(_lux_def Syntax' + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "lux;Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [(#Some #Nil) "lux;Syntax'" "w" + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) +(_lux_export Syntax') + +## (deftype Syntax +## (Meta Cursor (Syntax' (Meta Cursor)))) +(_lux_def Syntax + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) +(_lux_export Syntax) + +(_lux_def SyntaxList (#AppT [List Syntax])) + +## (deftype (Either l r) +## (| (#Left l) +## (#Right r))) +(_lux_def Either + (#AllT [(#Some #Nil) "lux;Either" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) +(_lux_export Either) + +## (deftype (StateE s a) +## (-> s (Either Text (, s a)))) +(_lux_def StateE + (#AllT [(#Some #Nil) "lux;StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) + +## (deftype Reader +## (List (Meta Cursor Text))) +(_lux_def Reader + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) +(_lux_export Reader) + +## (deftype HostState +## (& #writer (^ org.objectweb.asm.ClassWriter) +## #loader (^ java.net.URLClassLoader) +## #classes (^ clojure.lang.Atom))) +(_lux_def HostState + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] + #Nil])])]))) + +## (deftype (DefData' m) +## (| #TypeD +## (#ValueD Type) +## (#MacroD m) +## (#AliasD Ident))) +(_lux_def DefData' + (#AllT [(#Some #Nil) "lux;DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) +(_lux_export DefData') + +## (deftype LuxVar +## (| (#Local Int) +## (#Global Ident))) +(_lux_def LuxVar + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) +(_lux_export LuxVar) + +## (deftype (Module Compiler) +## (& #module-aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #imports (List Text) +## )) +(_lux_def Module + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + SyntaxList])])]) + #Nil])])) + #Nil])]))])] + (#Cons [["lux;imports" (#AppT [List Text])] + #Nil])])]))])) +(_lux_export Module) + +## (deftype #rec Compiler +## (& #source Reader +## #modules (List (, Text (Module Compiler))) +## #envs (List (Env Text (, LuxVar Type))) +## #types (Bindings Int Type) +## #host HostState +## #seed Int +## #eval? Bool)) +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + (#Cons [["lux;eval?" Bool] + #Nil])])])])])])]))]) + Void])) +(_lux_export Compiler) + +## (deftype Macro +## (-> (List Syntax) (StateE Compiler (List Syntax)))) +(_lux_def Macro + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE Compiler]) + SyntaxList])])) +(_lux_export Macro) + +## Base functions & macros +## (def _cursor +## Cursor +## ["" -1 -1]) +(_lux_def _cursor + (_lux_: Cursor ["" -1 -1])) + +## (def (_meta data) +## (-> (Syntax' (Meta Cursor)) Syntax) +## (#Meta [["" -1 -1] data])) +(_lux_def _meta + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [_cursor data])))) + +## (def (return x) +## (All [a] +## (-> a Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def return + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) + +## (def (fail msg) +## (All [a] +## (-> Text Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def fail + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [Text + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) + +(_lux_def text$ + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) + +(_lux_def symbol$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) + +(_lux_def tag$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) + +(_lux_def form$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) + +(_lux_def tuple$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) + +(_lux_def record$ + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) + +(_lux_def let' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) + + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') + +(_lux_def lambda' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + _ + (fail "Wrong syntax for lambda"))))) +(_lux_declare-macro lambda') + +(_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])) + + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def') + +(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"]) + (#Cons [body + #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"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +(defmacro #export (comment tokens) + (return #Nil)) + +(defmacro (->' tokens) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) + + (#Cons [input (#Cons [output others])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for ->'"))) + +(defmacro (All' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (#Cons [body + #Nil])) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for All'"))) + +(defmacro (B' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + #Nil]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for B'"))) + +(defmacro ($' tokens) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) + + (#Cons [x (#Cons [y xs])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) + + _ + (fail "Wrong syntax for $'"))) + +(def' (foldL f init xs) + (All' [a b] + (->' (->' (B' a) (B' b) (B' a)) + (B' a) + ($' List (B' b)) + (B' a))) + (_lux_case xs + #Nil + init + + (#Cons [x xs']) + (foldL f (f init x) xs'))) + +(def' (reverse list) + (All' [a] + (->' ($' List (B' a)) ($' List (B' a)))) + (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])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) + #Nil]))) + +(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))))))) + 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 (def'' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + body)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) + + _ + (fail "Wrong syntax for def") + )) + +(def'' (as-pairs xs) + (All' [a] + (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) + (_lux_case xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) + + _ + #Nil)) + +(defmacro #export (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))))) + body + (reverse (as-pairs bindings))))) + + _ + (fail "Wrong syntax for let"))) + +(def'' (map f xs) + (All' [a b] + (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) + +(def'' (any? p xs) + (All' [a] + (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) + (_lux_case xs + #Nil + false + + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) + +(def'' (spliced? token) + (->' Syntax Bool) + (_lux_case token + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + true + + _ + false)) + +(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) + (->' ($' List Syntax) Syntax) + (_lux_case tokens + #Nil + (_meta (#TagS ["lux" "Nil"])) + + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + +(def'' #export (list:++ xs ys) + (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) + (_lux_case xs + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) + + #Nil + ys)) + +(defmacro #export ($ tokens) + (_lux_case tokens + (#Cons [op (#Cons [init args])]) + (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) + init + args))) + + _ + (fail "Wrong syntax for $"))) + +(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')))))) + + 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) + (->' Bool Text Syntax Syntax) + (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) + [_ (#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))))) + + [_ (#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))))) + + [_ (#Meta [_ (#TextS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) + + [_ (#Meta [_ (#TagS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) + + [_ (#Meta [_ (#SymbolS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + 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) + + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + unquoted + + [_ (#Meta [_ (#FormS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + + [_ (#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)))))) + fields))))) + )) + +(defmacro (`' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate true "" template))) + + _ + (fail "Wrong syntax for `'"))) + +(defmacro (' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate false "" template))) + + _ + (fail "Wrong syntax for '"))) + +(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))) + + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) + +(defmacro #export (if tokens) + (_lux_case tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (`' (_lux_case (~ test) + true (~ then) + false (~ else))))) + + _ + (fail "Wrong syntax for if"))) + +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) +(def'' #export Lux + Type + (All' [a] + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) + +## (defsig (Monad m) +## (: (All [a] (-> a (m a))) +## return) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def'' Monad + Type + (All' [m] + (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] + ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))])))) + +(def'' Maybe/Monad + ($' Monad Maybe) + {#lux;return + (lambda return [x] + (#Some x)) + + #lux;bind + (lambda [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def'' Lux/Monad + ($' Monad Lux) + {#lux;return + (lambda [x] + (lambda [state] + (#Right [state x]))) + + #lux;bind + (lambda [f ma] + (lambda [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) + + (#Right [state' a]) + (f a state'))))}) + +(defmacro #export (^ tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) + + _ + (fail "Wrong syntax for ^"))) + +(defmacro #export (-> tokens) + (_lux_case (reverse tokens) + (#Cons [output inputs]) + (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) + + _ + (fail "Wrong syntax for ->"))) + +(defmacro #export (, tokens) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) + +(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')))))) + + _ + (fail "Wrong syntax for do"))) + +(def'' (map% m f xs) + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All' [m a b] + (-> ($' Monad (B' m)) + (-> (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]))) + ))) + +(def'' #export (. f g) + (All' [a b c] + (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) + (lambda [x] + (f (g x)))) + +(def'' (get-ident x) + (-> Syntax ($' Maybe Text)) + (_lux_case x + (#Meta [_ (#SymbolS ["" sname])]) + (#Some sname) + + _ + #None)) + +(def'' (tuple->list tuple) + (-> Syntax ($' Maybe ($' List Syntax))) + (_lux_case tuple + (#Meta [_ (#TupleS members)]) + (#Some members) + + _ + #None)) + +(def'' RepEnv + Type + ($' List (, Text Syntax))) + +(def'' (make-env xs ys) + (-> ($' List Text) ($' List Syntax) RepEnv) + (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + [xs ys]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) + + _ + #Nil)) + +(def'' #export (text:= x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y])) + +(def'' (get-rep key env) + (-> Text RepEnv ($' Maybe Syntax)) + (_lux_case env + #Nil + #None + + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) + +(def'' (apply-template env template) + (-> RepEnv Syntax Syntax) + (_lux_case template + (#Meta [_ (#SymbolS ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst + + _ + template) + + (#Meta [_ (#TupleS elems)]) + (tuple$ (map (apply-template env) elems)) + + (#Meta [_ (#FormS elems)]) + (form$ (map (apply-template env) elems)) + + (#Meta [_ (#RecordS members)]) + (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) + + _ + template)) + +(def'' (join-map f xs) + (All' [a b] + (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) + +(defmacro #export (do-template tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(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)) + + _ + (fail "Wrong syntax for do-template")) + + _ + (fail "Wrong syntax for do-template"))) + +(do-template [ ] + [(def'' #export ( x y) + (-> Bool) + ( x y))] + + [i= _jvm_leq Int] + [i> _jvm_lgt Int] + [i< _jvm_llt Int] + [r= _jvm_deq Real] + [r> _jvm_dgt Real] + [r< _jvm_dlt Real] + ) + +(do-template [ ] + [(def'' #export ( x y) + (-> Bool) + (if ( x y) + true + ( x y)))] + + [i>= i> i= Int] + [i<= i< i= Int] + [r>= r> r= Real] + [r<= r< r= Real] + ) + +(do-template [ ] + [(def'' #export ( x y) + (-> ) + ( x y))] + + [i+ _jvm_ladd Int] + [i- _jvm_lsub Int] + [i* _jvm_lmul Int] + [i/ _jvm_ldiv Int] + [i% _jvm_lrem Int] + [r+ _jvm_dadd Real] + [r- _jvm_dsub Real] + [r* _jvm_dmul Real] + [r/ _jvm_ddiv Real] + [r% _jvm_drem Real] + ) + +(def'' (multiple? div n) + (-> Int Int Bool) + (i= 0 (i% n div))) + +(def'' (length list) + (-> List Int) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + +(def'' #export (not x) + (-> Bool Bool) + (if x false true)) + +(def'' #export (text:++ x y) + (-> Text Text Text) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) + +(def'' (ident->text ident) + (-> Ident Text) + (let [[module name] ident] + ($ text:++ module ";" name))) + +(def'' (replace-syntax reps syntax) + (-> RepEnv Syntax Syntax) + (_lux_case syntax + (#Meta [_ (#SymbolS ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) + + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) + + (#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)]))) + slots))]) + + _ + syntax) + ) + +(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)) + + (#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")) + )) + +(def'' (get k plist) + (All [a] + (-> Text ($' List (, Text a)) ($' Maybe a))) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) + + #Nil + #None)) + +(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 + #envs envs #types types #host host + #seed seed #eval? eval?} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") + + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state 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))] + (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) + +(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) + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (foldL list:++ #Nil xs)) + +(def'' (normalize ident) + (-> Ident ($' Lux Ident)) + (_lux_case ident + ["" name] + (do Lux/Monad + [module-name get-module-name] + (;return (_lux_: Ident [module-name name]))) + + _ + (return ident))) + +(defmacro #export (| tokens) + (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 |")))) + tokens)] + (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) + +(defmacro #export (& tokens) + (if (not (multiple? 2 (length tokens))) + (fail "& expects an even number of arguments.") + (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 &")))) + (as-pairs tokens))] + (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) + +(def'' #export (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual java.lang.Object toString [] x [])) + +(def'' (interpose sep xs) + (All [a] + (-> a ($' List a) ($' List a))) + (_lux_case xs + #Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) + +(def'' (macro-expand syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand expansion)] + (;return (list:join expansion'))) + + #None + (do Lux/Monad + [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+)))))) + + (#Meta [_ (#TupleS members)]) + (do Lux/Monad + [members' (map% Lux/Monad macro-expand members)] + (;return (list (tuple$ (list:join members'))))) + + _ + (return (list syntax)))) + +(def'' (walk-type type) + (-> Syntax Syntax) + (_lux_case type + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) + + (#Meta [_ (#TupleS members)]) + (tuple$ (map walk-type members)) + + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) + +(defmacro #export (type tokens) + (_lux_case tokens + (#Cons [type #Nil]) + (do Lux/Monad + [type+ (macro-expand type)] + (_lux_case type+ + (#Cons [type' #Nil]) + (;return (list (walk-type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type"))) + +(defmacro #export (: tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_: (;type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :"))) + +(defmacro #export (:! tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :!"))) + +(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'] + + _ + [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]) + + (#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 + (fail "Wrong syntax for deftype"))) + + #None + (fail "Wrong syntax for deftype")) + )) +## (defmacro #export (deftype tokens) +## (let [[export? tokens'] (: (, Bool (List Syntax)) +## (_lux_case (:! (List Syntax) tokens) +## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) +## [true (:! (List Syntax) tokens')] + +## _ +## [false (:! (List Syntax) tokens)])) +## parts (: (Maybe (, Syntax (List Syntax) Syntax)) +## (_lux_case tokens' +## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) #Nil type]) + +## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) args type]) + +## _ +## #None))] +## (_lux_case parts +## (#Some [name args type]) +## (let [with-export (: (List Syntax) +## (if export? +## (list (`' (_lux_export (~ name)))) +## #Nil)) +## type' (: Syntax +## (_lux_case args +## #Nil +## type + +## _ +## (`' (;All (~ name) [(~@ args)] (~ type)))))] +## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) +## with-export))) + +## #None +## (fail "Wrong syntax for deftype")) +## )) + +(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)))) + + _ + (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'] + + _ + [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 + + _ + (`' (;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) + (-> (, Syntax Syntax) (List Syntax)) + (let [[left right] pair] + (list left right))) + +(defmacro #export (case tokens) + (_lux_case tokens + (#Cons [value branches]) + (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)))))) + (as-pairs branches))] + (;return (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + + _ + (fail "Wrong syntax for case"))) + +(defmacro #export (\ tokens) + (case tokens + (#Cons [body (#Cons [pattern #Nil])]) + (do Lux/Monad + [pattern+ (macro-expand pattern)] + (case pattern+ + (#Cons [pattern' #Nil]) + (;return (list pattern' body)) + + _ + (fail "\\ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for \\"))) + +(defmacro #export (\or tokens) + (case tokens + (#Cons [body patterns]) + (case patterns + #Nil + (fail "\\or can't have 0 patterns") + + _ + (do Lux/Monad + [patterns' (map% Lux/Monad macro-expand patterns)] + (;return (list:join (map (lambda [pattern] (list pattern body)) + (list:join patterns')))))) + + _ + (fail "Wrong syntax for \\or"))) + +(do-template [ ] + [(def #export (i+ ))] + + [inc 1] + [dec -1]) + +(defmacro #export (` tokens) + (do Lux/Monad + [module-name get-module-name] + (case tokens + (\ (list template)) + (;return (list (untemplate true module-name template))) + + _ + (fail "Wrong syntax for `")))) + +(def (gensym prefix state) + (-> Text (Lux Syntax)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [{#source source #modules modules + #envs envs #types types #host host + #seed (inc seed) #eval? eval?} + (symbol$ ["__gensym__" (->text seed)])]))) + +(def (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux/Monad + [token+ (macro-expand token)] + (case token+ + (\ (list token')) + (;return token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(defmacro #export (sig tokens) + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad + (: (-> Syntax (Lux (, Ident Syntax))) + (lambda [token] + (case token + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (do Lux/Monad + [name' (normalize name)] + (;return (: (, Ident Syntax) [name' type]))) + + _ + (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))))))))) + +(defmacro #export (defsig tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) + (#Some [name args sigs]) + + (\ (list& name sigs)) + (#Some [name #Nil sigs]) + + _ + #None))] + (case ?parts + (#Some [name args sigs]) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) + + _ + (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for defsig")))) + +(defmacro #export (struct tokens) + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [token] + (case token + (\ (#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!")))) + (list:join tokens'))] + (;return (list (record$ members))))) + +(defmacro #export (defstruct tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) + (#Some [name args type defs]) + + (\ (list& name type defs)) + (#Some [name #Nil type defs]) + + _ + #None))] + (case ?parts + (#Some [name args type defs]) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) + + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for defstruct")))) + +(def #export (id x) + (All [a] (-> a a)) + x) + +(do-template [ ] + [(defmacro #export ( tokens) + (case (reverse tokens) + (\ (list& last init)) + (return (list (foldL (lambda [post pre] (` )) + last + init))) + + _ + (fail )))] + + [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] + [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) + +(deftype Referrals + (| #All + (#Only (List Text)) + (#Exclude (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/exclude 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 ["" "exclude"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Exclude 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 + #seed seed #eval? eval?} + (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 #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? + (list name) + (list))))) + (let [{#module-aliases _ #defs defs #imports _} =module] + defs))] + (#Right [state (list:join to-alias)])) + + #None + (#Left ($ text:++ "Unknown module: " module))) + )) + +(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) + (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + text [part]))) + +(def (substring1 idx text) + (-> Int Text Text) + (_jvm_invokevirtual java.lang.String substring [int] + text [(_jvm_l2i idx)])) + +(def (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_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 (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module))))])) + +(def (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< 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 (i= 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 (i= 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))) + + (#Exclude -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) + module (substring2 0 idx slot) + 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 + (#RecordT slots) + (#Some type) + + (#AppT [fun arg]) + (apply-type fun arg) + + (#AllT [_ _ _ body]) + (resolve-struct-type body) + + _ + #None)) + +(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 (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 #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 + closure)))) + 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 #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 #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 #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 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$ ["" ""])] + (return (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body)))))))) + + _ + (fail "Wrong syntax for using"))) + +(def #export (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.") + (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 (\template tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS data)]) + (#Meta [_ (#TupleS bindings)]) + (#Meta [_ (#TupleS templates)]))) + (case (: (Maybe (List Syntax)) + (do Maybe/Monad + [bindings' (map% Maybe/Monad get-ident bindings) + data' (map% Maybe/Monad tuple->list data)] + (let [apply (: (-> RepEnv (List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + ;return)))) + (#Some output) + (return output) + + #None + (fail "Wrong syntax for \\template")) + + _ + (fail "Wrong syntax for \\template"))) + +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) + +## (defmacro #export (loop tokens) +## (case tokens +## (\ (list bindings body)) +## (let [pairs (as-pairs bindings) +## vars (map first pairs) +## inits (map second pairs)] +## (if (every? symbol? inits) +## (do Lux/Monad +## [inits' (map% Maybe/Monad get-ident inits) +## init-types (map% Maybe/Monad find-var-type inits')] +## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] +## (~ body)) +## (~@ inits)))))) +## (do Lux/Monad +## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] +## (return (list (` (let [(~@ (interleave aliases inits))] +## (loop [(~@ (interleave vars aliases))] +## (~ body))))))))) + +## _ +## (fail "Wrong syntax for loop"))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux new file mode 100644 index 000000000..1d6dd1b50 --- /dev/null +++ b/source/lux/codata/stream.lux @@ -0,0 +1,133 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (lazy #as L #refer #all) + (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))))) + +## [Types] +(deftype #export (Stream a) + (Lazy (, a (Stream a)))) + +## [Utils] +(def (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (cycle' init full init full) + (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + +## [Functions] +(def #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (... [x (iterate f (f x))])) + +(def #export (repeat x) + (All [a] + (-> a (Stream a))) + (... [x (repeat x)])) + +(def #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + +(do-template [ ] + [(def #export ( s) + (All [a] (-> (Stream a) )) + (let [[h t] (! s)] + ))] + + [head a h] + [tail (Stream a) t]) + +(def #export (@ idx s) + (All [a] (-> Int (Stream a) a)) + (let [[h t] (! s)] + (if (i> idx 0) + (@ (dec idx) t) + h))) + +(do-template [ ] + [(def #export ( det xs) + (All [a] + (-> (Stream a) (List a))) + (let [[x xs'] (! xs)] + (if + (list& x ( xs')) + (list)))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if + ( xs') + xs))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (, (List a) (Stream a)))) + (let [[x xs'] (! xs)] + (if + (let [[tail next] ( xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (det x) det] + [take drop split Int (i> det 0) (dec det)] + ) + +(def #export (unfold step init) + (All [a b] + (-> (-> a (, a b)) a (Stream b))) + (let [[next x] (step init)] + (... [x (unfold step next)]))) + +(def #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if (p x) + (... [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(defstruct #export Stream/Functor (Functor Stream) + (def (F;map f fa) + (let [[h t] (! fa)] + (... [(f h) (F;map f t)])))) + +(defstruct #export Stream/CoMonad (CoMonad Stream) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) + (:: Stream/Functor (F;map repeat wa)))) + +## [Pattern-matching] +(defsyntax #export (\stream body [patterns' (+^ id^)]) + (do Lux/Monad + [patterns (map% Lux/Monad macro-expand-1 patterns') + g!s (gensym "s") + #let [patterns+ (: (List Syntax) + (do List/Monad + [pattern (l;reverse patterns)] + (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] + (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux new file mode 100644 index 000000000..1830ff44f --- /dev/null +++ b/source/lux/control/comonad.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../functor #as F) + lux/data/list + lux/meta/macro) + +## Signatures +(defsig #export (CoMonad w) + (: (F;Functor w) + _functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +## Functions +(def #export (extend w f ma) + (All [w a b] + (-> (CoMonad w) (-> (w a) b) (w a) (w b))) + (using w + (using ;;_functor + (F;map f (;;split ma))))) + +## Syntax +(defmacro #export (be tokens state) + (case tokens + (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (extend (;lambda [(~ var)] (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (list (` (;case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))])) + + _ + (#;Left "Wrong syntax for be"))) diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux new file mode 100644 index 000000000..6a9dcfff8 --- /dev/null +++ b/source/lux/control/functor.lux @@ -0,0 +1,15 @@ +## 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 (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux new file mode 100644 index 000000000..22dac74fe --- /dev/null +++ b/source/lux/control/lazy.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (.. (functor #as F #refer #all) + (monad #as M #refer #all)) + (lux/data list)) + +## Types +(deftype #export (Lazy a) + (All [b] + (-> (-> a b) b))) + +## Syntax +(defmacro #export (... tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for ..."))) + +## Functions +(def #export (! thunk) + (All [a] + (-> (Lazy a) a)) + (thunk id)) + +## Structs +(defstruct #export Lazy/Functor (Functor Lazy) + (def (F;map f ma) + (lambda [k] (ma (. k f))))) + +(defstruct #export Lazy/Monad (Monad Lazy) + (def M;_functor Lazy/Functor) + + (def (M;wrap a) + (... a)) + + (def M;join !)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux new file mode 100644 index 000000000..b5552f987 --- /dev/null +++ b/source/lux/control/monad.lux @@ -0,0 +1,99 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (functor #as F) + (monoid #as M)) + lux/meta/macro) + +## [Utils] +(def (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (#;Cons [x1 (#;Cons [x2 xs'])]) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +## [Signatures] +(defsig #export (Monad m) + (: (F;Functor m) + _functor) + (: (All [a] + (-> a (m a))) + wrap) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +## [Syntax] +(defmacro #export (do tokens state) + (case tokens + ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (;case ;;_functor + {#F;map F;map} + (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) + ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (#;Cons [(` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))) + #;Nil])])) + + _ + (#;Left "Wrong syntax for do"))) + +## [Functions] +(def #export (bind m f ma) + (All [m a b] + (-> (Monad m) (-> a (m b)) (m a) (m b))) + (using m + (;;join (:: ;;_functor (F;map f ma))))) + +(def #export (map% m f xs) + (All [m a b] + (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (case xs + #;Nil + (:: m (;;wrap #;Nil)) + + (#;Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;;wrap (#;Cons [y ys]))) + )) diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux new file mode 100644 index 000000000..d32baabc5 --- /dev/null +++ b/source/lux/control/monoid.lux @@ -0,0 +1,24 @@ +## 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 (Monoid a) + (: a + unit) + (: (-> a a a) + ++)) + +## Constructors +(def #export (monoid$ unit ++) + (All [a] + (-> a (-> a a a) (Monoid a))) + (struct + (def unit unit) + (def ++ ++))) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux new file mode 100644 index 000000000..d4f223612 --- /dev/null +++ b/source/lux/data/bool.lux @@ -0,0 +1,33 @@ +## 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) + (show #as S))) + +## [Structures] +(defstruct #export Bool/Eq (E;Eq Bool) + (def (E;= x y) + (if x + y + (not y)))) + +(defstruct #export Bool/Show (S;Show Bool) + (def (S;show x) + (if x "true" "false"))) + +(do-template [ ] + [(defstruct #export (m;Monoid Bool) + (def m;unit ) + (def (m;++ x y) + ( x y)))] + + [ Or/Monoid false or] + [And/Monoid true and] + ) diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux new file mode 100644 index 000000000..9d2dabde1 --- /dev/null +++ b/source/lux/data/bounded.lux @@ -0,0 +1,17 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux new file mode 100644 index 000000000..42e57509e --- /dev/null +++ b/source/lux/data/char.lux @@ -0,0 +1,20 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Char/Eq (E;Eq Char) + (def (E;= x y) + (_jvm_ceq x y))) + +(defstruct #export Char/Show (S;Show Char) + (def (S;show x) + ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux new file mode 100644 index 000000000..63a66d49b --- /dev/null +++ b/source/lux/data/dict.lux @@ -0,0 +1,83 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (eq #as E))) + +## Signatures +(defsig #export (Dict d) + (: (All [k v] + (-> k (d k v) (Maybe v))) + get) + (: (All [k v] + (-> k v (d k v) (d k v))) + put) + (: (All [k v] + (-> k (d k v) (d k v))) + remove)) + +## Types +(deftype #export (PList k v) + (| (#PList (, (E;Eq k) (List (, k v)))))) + +## Constructors +(def #export (plist eq) + (All [k v] + (-> (E;Eq k) (PList k v))) + (#PList [eq #;Nil])) + +## Utils +(def (pl-get eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (Maybe v))) + (case kvs + #;Nil + #;None + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Some v') + (pl-get eq k kvs')))) + +(def (pl-put eq k v kvs) + (All [k v] + (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + (#;Cons [[k v] kvs]) + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Cons [[k v] kvs']) + (#;Cons [[k' v'] (pl-put eq k v kvs')])))) + +(def (pl-remove eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (pl-remove eq k kvs')])))) + +## Structs +(defstruct #export PList/Dict (Dict PList) + (def (get k plist) + (let [(#PList [eq kvs]) plist] + (pl-get eq k kvs))) + + (def (put k v plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-put eq k v kvs)]))) + + (def (remove k plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux new file mode 100644 index 000000000..eba6438db --- /dev/null +++ b/source/lux/data/either.lux @@ -0,0 +1,46 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (list #refer (#exclude partition)))) + +## [Types] +## (deftype (Either l r) +## (| (#;Left l) +## (#;Right r))) + +## [Functions] +(def #export (either f g e) + (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) + (case e + (#;Left x) (f x) + (#;Right x) (g x))) + +(do-template [ ] + [(def #export ( es) + (All [a b] (-> (List (Either a b)) (List ))) + (case es + #;Nil #;Nil + (#;Cons [( x) es']) (#;Cons [x ( es')]) + (#;Cons [_ es']) ( es')))] + + [lefts a #;Left] + [rights b #;Right] + ) + +(def #export (partition es) + (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) + (foldL (: (All [a b] + (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) + (lambda [tails e] + (let [[ltail rtail] tails] + (case e + (#;Left x) [(#;Cons [x ltail]) rtail] + (#;Right x) [ltail (#;Cons [x rtail])])))) + [(list) (list)] + (reverse es))) diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux new file mode 100644 index 000000000..be3400208 --- /dev/null +++ b/source/lux/data/eq.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Signatures] +(defsig #export (Eq a) + (: (-> a a Bool) + =)) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux new file mode 100644 index 000000000..cb5c309a6 --- /dev/null +++ b/source/lux/data/error.lux @@ -0,0 +1,34 @@ +## 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 (Error a) + (| (#Fail Text) + (#Ok a))) + +## [Structures] +(defstruct #export Error/Functor (Functor Error) + (def (F;map f ma) + (case ma + (#Fail msg) (#Fail msg) + (#Ok datum) (#Ok (f datum))))) + +(defstruct #export Error/Monad (Monad Error) + (def M;_functor Error/Functor) + + (def (M;wrap a) + (#Ok a)) + + (def (M;join mma) + (case mma + (#Fail msg) (#Fail msg) + (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux new file mode 100644 index 000000000..0e3bdbee6 --- /dev/null +++ b/source/lux/data/id.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 (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Id a) + (| (#Id a))) + +## [Structures] +(defstruct #export Id/Functor (Functor Id) + (def (F;map f fa) + (let [(#Id a) fa] + (#Id (f a))))) + +(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))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux new file mode 100644 index 000000000..c08023df5 --- /dev/null +++ b/source/lux/data/io.lux @@ -0,0 +1,51 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (lux/control (functor #as F) + (monad #as M)) + lux/data/list) + +## Types +(deftype #export (IO a) + (-> (,) a)) + +## Syntax +(defmacro #export (io tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## Structures +(defstruct #export IO/Functor (F;Functor IO) + (def (F;map f ma) + (io (f (ma []))))) + +(defstruct #export IO/Monad (M;Monad IO) + (def M;_functor IO/Functor) + + (def (M;wrap x) + (io x)) + + (def (M;join mma) + (mma []))) + +## Functions +(def #export (print x) + (-> Text (IO (,))) + (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]))) + +(def #export (println x) + (-> Text (IO (,))) + (print (text:++ x "\n"))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux new file mode 100644 index 000000000..450dee275 --- /dev/null +++ b/source/lux/data/list.lux @@ -0,0 +1,250 @@ +## 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 #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) + lux/meta/macro) + +## Types +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) + +## Functions +(def #export (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def #export (foldR f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (f x (foldR f init xs')))) + +(def #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) + [(filter p xs) (filter (complement p) xs)]) + +(def #export (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (\ (#;Cons [x1 (#;Cons [x2 xs'])])) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +(do-template [ ] + [(def #export ( n xs) + (All [a] + (-> Int (List a) (List a))) + (if (i> n 0) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + ) + ))] + + [take (#;Cons [x (take (dec n) xs')]) #;Nil] + [drop (drop (dec n) xs') xs] + ) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + + )))] + + [take-while (#;Cons [x (take-while p xs')]) #;Nil] + [drop-while (drop-while p xs') xs] + ) + +(def #export (split n xs) + (All [a] + (-> Int (List a) (, (List a) (List a)))) + (if (i> n 0) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split (dec n) xs')] + [(#;Cons [x tail]) rest])) + [#;Nil xs])) + +(def (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) + (case xs + #;Nil + [ys xs] + + (#;Cons [x xs']) + (if (p x) + (split-with' p (#;Cons [x ys]) xs') + [ys xs]))) + +(def #export (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) (, (List a) (List a)))) + (let [[ys' xs'] (split-with' p #;Nil xs)] + [(reverse ys') xs'])) + +(def #export (repeat n x) + (All [a] + (-> Int a (List a))) + (if (i> n 0) + (#;Cons [x (repeat (dec n) x)]) + #;Nil)) + +(def #export (iterate f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (#;Cons [x (iterate f x')]) + + #;None + (#;Cons [x #;Nil]))) + +(def #export (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (case (f x) + #;None + (some f xs') + + (#;Some y) + (#;Some y)))) + +(def #export (interpose sep xs) + (All [a] + (-> a (List a) (List a))) + (case xs + #;Nil + xs + + (#;Cons [x #;Nil]) + xs + + (#;Cons [x xs']) + (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) + +(def #export (size list) + (-> List Int) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] + + [every? true and] + [any? false or]) + +(def #export (@ i xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (i= 0 i) + (#;Some x) + (@ (dec i) xs')))) + +## Syntax +(defmacro #export (list xs state) + (#;Right [state (#;Cons [(foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + (` #;Nil) + (reverse xs)) + #;Nil])])) + +(defmacro #export (list& xs state) + (case (reverse xs) + (#;Cons [last init]) + (#;Right [state (list (foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + last + init))]) + + _ + (#;Left "Wrong syntax for list&"))) + +## Structures +(defstruct #export List/Monoid (All [a] + (Monoid (List a))) + (def m;unit #;Nil) + (def (m;++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + +(defstruct #export List/Functor (Functor List) + (def (F;map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + +(defstruct #export List/Monad (Monad List) + (def M;_functor List/Functor) + + (def (M;wrap a) + (#;Cons [a #;Nil])) + + (def (M;join mma) + (using List/Monoid + (foldL m;++ m;unit mma)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux new file mode 100644 index 000000000..faec53c2e --- /dev/null +++ b/source/lux/data/maybe.lux @@ -0,0 +1,42 @@ +## 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 #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +## (deftype (Maybe a) +## (| #;None +## (#;Some a))) + +## [Structures] +(defstruct #export Maybe/Monoid (Monoid Maybe) + (def m;unit #;None) + (def (m;++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export Maybe/Functor (Functor Maybe) + (def (F;map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export Maybe/Monad (Monad Maybe) + (def M;_functor Maybe/Functor) + + (def (M;wrap x) + (#;Some x)) + + (def (M;join mma) + (case mma + #;None #;None + (#;Some xs) xs))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux new file mode 100644 index 000000000..8da674d88 --- /dev/null +++ b/source/lux/data/number.lux @@ -0,0 +1,119 @@ +## 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)) + (lux/data (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## Signatures +(defsig #export (Number n) + (do-template [] + [(: (-> n n n) )] + [+] [-] [*] [/] [%]) + + (: (-> Int n) + from-int) + + (do-template [] + [(: (-> n n) )] + [negate] [signum] [abs]) + ) + +## [Structures] +## Number +(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] + [(defstruct #export (Number ) + (def + <+>) + (def - <->) + (def * <*>) + (def / ) + (def % <%>) + (def (from-int x) + ( x)) + (def (negate x) + (<*> <-1> x)) + (def (abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (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]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def E;= i=)) + +(defstruct #export Real/Eq (E;Eq Real) + (def E;= r=)) + +## Ord +## (def #export Int/Ord (O;Ord Int) +## (O;ord$ Int/Eq i< i>)) + +## (def #export Real/Ord (O;Ord Real) +## (O;ord$ Real/Eq r< r>)) + +(do-template [ ] + [(defstruct #export (O;Ord ) + (def O;_eq ) + (def O;< ) + (def (O;<= x y) + (or ( x y) + (using (E;= x y)))) + (def O;> ) + (def (O;>= x y) + (or ( x y) + (using (E;= x y)))))] + + [ Int/Ord Int Int/Eq i< i>] + [Real/Ord Real Real/Eq r< r>]) + +## Bounded +(do-template [ ] + [(defstruct #export (B;Bounded ) + (def B;top ) + (def B;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 [ <++>] + [(defstruct #export (m;Monoid ) + (def m;unit ) + (def m;++ <++>))] + + [ 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)] + [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] + ) + +## Show +(do-template [ ] + [(defstruct #export (S;Show ) + (def (S;show x) + ))] + + [ 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/ord.lux b/source/lux/data/ord.lux new file mode 100644 index 000000000..80f2e4fb5 --- /dev/null +++ b/source/lux/data/ord.lux @@ -0,0 +1,44 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../eq #as E)) + +## [Signatures] +(defsig #export (Ord a) + (: (E;Eq a) + _eq) + (do-template [] + [(: (-> a a Bool) )] + + [<] [<=] [>] [>=])) + +## [Constructors] +(def #export (ord$ eq < >) + (All [a] + (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) + (struct + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) + +## [Functions] +(do-template [ ] + [(def #export ( ord x y) + (All [a] + (-> (Ord a) a a a)) + (if (:: ord ( x y)) x y))] + + [max ;;>] + [min ;;<]) diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux new file mode 100644 index 000000000..e91687c3a --- /dev/null +++ b/source/lux/data/reader.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#exclude Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (F;map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def M;_functor Reader/Functor) + + (def (M;wrap x) + (lambda [env] x)) + + (def (M;join mma) + (lambda [env] + (mma env env)))) diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux new file mode 100644 index 000000000..f4e1cf762 --- /dev/null +++ b/source/lux/data/show.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Show a) + (: (-> a Text) + show)) diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux new file mode 100644 index 000000000..bc9858a29 --- /dev/null +++ b/source/lux/data/state.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (State s a) + (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (Functor State) + (def (F;map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def M;_functor State/Functor) + + (def (M;wrap x) + (lambda [state] + [state x])) + + (def (M;join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux new file mode 100644 index 000000000..a3192a1d5 --- /dev/null +++ b/source/lux/data/text.lux @@ -0,0 +1,146 @@ +## 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)) + (lux/data (eq #as E) + (ord #as O) + (show #as S))) + +## [Functions] +(def #export (size x) + (-> Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] + x []))) + +(def #export (@ idx x) + (-> Int Text (Maybe Char)) + (if (and (i< idx (size x)) + (i>= idx 0)) + (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + x [(_jvm_l2i idx)])) + #;None)) + +(def #export (contains? x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] + x [y])) + +(do-template [ ] + [(def #export ( x) + (-> Text Text) + (_jvm_invokevirtual java.lang.String [] + x []))] + [lower-case toLowerCase] + [upper-case toUpperCase] + [trim trim] + ) + +(def #export (sub' from to x) + (-> Int Int Text (Maybe Text)) + (if (and (i< from to) + (i>= from 0) + (i<= to (size x))) + (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i from) (_jvm_l2i to)]) + #;None)) + +(def #export (sub from x) + (-> Int Text (Maybe Text)) + (sub' from (size x) x)) + +(def #export (split at x) + (-> Int Text (Maybe (, Text Text))) + (if (and (i< at (size x)) + (i>= at 0)) + (let [pre (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i 0) (_jvm_l2i at)]) + post (_jvm_invokevirtual java.lang.String substring [int] + x [(_jvm_l2i at)])] + (#;Some [pre post])) + #;None)) + +(def #export (replace pattern value template) + (-> Text Text Text Text) + (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] + template [pattern value])) + +(do-template [ ] + [(def #export ( pattern from x) + (-> Text Int Text (Maybe Int)) + (if (and (i< from (size x)) (i>= from 0)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] + x [pattern (_jvm_l2i from)])) + -1 #;None + idx (#;Some idx)) + #;None)) + + (def #export ( pattern x) + (-> Text Text (Maybe Int)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] + x [pattern])) + -1 #;None + idx (#;Some idx)))] + + [index-of index-of' indexOf] + [last-index-of last-index-of' lastIndexOf] + ) + +(def #export (starts-with? prefix x) + (-> Text Text Bool) + (case (index-of prefix x) + (#;Some 0) + true + + _ + false)) + +(def #export (ends-with? postfix x) + (-> Text Text Bool) + (case (last-index-of postfix x) + (#;Some n) + (i= (i+ n (size postfix)) + (size x)) + + _ + false)) + +## [Structures] +(defstruct #export Text/Eq (E;Eq Text) + (def (E;= x y) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y]))) + +(defstruct #export Text/Ord (O;Ord Text) + (def O;_eq Text/Eq) + (def (O;< x y) + (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;<= x y) + (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;> x y) + (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;>= x y) + (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) + +(defstruct #export Text/Show (S;Show Text) + (def (S;show x) + x)) + +(defstruct #export Text/Monoid (m;Monoid Text) + (def m;unit "") + (def (m;++ x y) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux new file mode 100644 index 000000000..f71492e35 --- /dev/null +++ b/source/lux/data/writer.lux @@ -0,0 +1,34 @@ +## 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 #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Writer l a) + (, l a)) + +## [Structures] +(defstruct #export Writer/Functor (All [l] + (Functor (Writer l))) + (def (F;map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(defstruct #export (Writer/Monad mon) (All [l] + (-> (Monoid l) (Monad (Writer l)))) + (def M;_functor Writer/Functor) + + (def (M;wrap x) + [(:: mon m;unit) x]) + + (def (M;join mma) + (let [[log1 [log2 a]] mma] + [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux new file mode 100644 index 000000000..12525d3f2 --- /dev/null +++ b/source/lux/host/java.lux @@ -0,0 +1,312 @@ +## 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) + (functor #as F) + (monad #as M #refer (#only do))) + (data list + (text #as text)) + (meta lux + macro + syntax))) + +## (open List/Functor) + +## [Utils/Parsers] +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Utils/Lux] +## (def (find-class-field field class) +## (-> Text Text (Lux Type)) +## ...) + +## (def (find-virtual-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + +## (def (find-static-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches)) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally)))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + members))] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + fields)) + methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs)))] + (~ (text$ output)) + [(~@ (:: List/Functor (F;map text$ modifiers)))] + (~ body)))))) + methods))]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +## (defsyntax #export (.? [field local-symbol^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) + +## _ +## (fail "Can only get field from object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.? (~ field) (~ g!obj))))))))) + +## (defsyntax #export (.= [field local-symbol^] value obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) + +## _ +## (fail "Can only set field of object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.= (~ field) (~ value) (~ g!obj))))))))) + +## (defsyntax #export (.! [call method-call^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-virtual-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] +## (~ obj) [(~@ m-args)]))))) + +## _ +## (fail "Can only call method on object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.! (~@ *tokens*))))))))) + +## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) +## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) +## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +## (defsyntax #export (..! [call method-call^] [class local-symbol^]) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-static-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) +## [(~@ (:: List/Functor (F;map text$ m-ins)))] +## [(~@ m-args)])))) +## )) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux new file mode 100644 index 000000000..2e29c5da7 --- /dev/null +++ b/source/lux/math.lux @@ -0,0 +1,60 @@ +## 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) + +## [Constants] +(do-template [ ] + [(def #export + Real + (_jvm_getstatic java.lang.Math ))] + + [e E] + [pi PI] + ) + +## [Functions] +(do-template [ ] + [(def #export ( n) + (-> Real Real) + (_jvm_invokestatic java.lang.Math [double] [n]))] + + [cos cos] + [sin sin] + [tan tan] + + [acos acos] + [asin asin] + [atan atan] + + [cosh cosh] + [sinh sinh] + [tanh tanh] + + [ceil ceil] + [floor floor] + [round round] + + [exp exp] + [log log] + + [cbrt cbrt] + [sqrt sqrt] + + [->degrees toDegrees] + [->radians toRadians] + ) + +(do-template [ ] + [(def #export ( x y) + (-> Real Real Real) + (_jvm_invokestatic java.lang.Math [double double] [x y]))] + + [atan2 atan2] + [pow pow] + ) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux new file mode 100644 index 000000000..a28d6e5d4 --- /dev/null +++ b/source/lux/meta/lux.lux @@ -0,0 +1,287 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. macro) + (lux/control (monoid #as m) + (functor #as F) + (monad #as M #refer (#only do))) + (lux/data list + maybe + (show #as S) + (number #as N))) + +## [Types] +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) + +## [Utils] +(def (ident->text ident) + (-> Ident Text) + (let [[pre post] ident] + ($ text:++ pre ";" post))) + +## [Structures] +(defstruct #export Lux/Functor (F;Functor Lux) + (def (F;map f fa) + (lambda [state] + (case (fa state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' a]) + (#;Right [state' (f a)]))))) + +(defstruct #export Lux/Monad (M;Monad Lux) + (def M;_functor Lux/Functor) + (def (M;wrap x) + (lambda [state] + (#;Right [state x]))) + (def (M;join mma) + (lambda [state] + (case (mma state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' ma]) + (ma state'))))) + +## Functions +(def #export (get-module-name state) + (Lux Text) + (case (reverse (get@ #;envs state)) + #;Nil + (#;Left "Can't get the module name without a module!") + + (#;Cons [env _]) + (#;Right [state (get@ #;name env)]))) + +(def (get k plist) + (All [a] + (-> Text (List (, Text a)) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [[k' v] plist']) + (if (text:= k k') + (#;Some v) + (get k plist')))) + +(def (find-macro' modules current-module module name) + (-> (List (, Text (Module Compiler))) Text Text Text + (Maybe Macro)) + (do Maybe/Monad + [$module (get module modules) + gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] + (case (: (, Bool (DefData' Macro)) gdef) + [exported? (#;MacroD macro')] + (if (or exported? (text:= module current-module)) + (#;Some macro') + #;None) + + [_ (#;AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #;None))) + +(def #export (find-macro ident) + (-> Ident (Lux (Maybe Macro))) + (do Lux/Monad + [current-module get-module-name] + (let [[module name] ident] + (: (Lux (Maybe Macro)) + (lambda [state] + (#;Right [state (find-macro' (get@ #;modules state) current-module module name)])))))) + +(def #export (normalize ident) + (-> Ident (Lux Ident)) + (case ident + ["" name] + (do Lux/Monad + [module-name get-module-name] + (M;wrap (: Ident [module-name name]))) + + _ + (:: Lux/Monad (M;wrap ident)))) + +(def #export (macro-expand syntax) + (-> Syntax (Lux (List Syntax))) + (case syntax + (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (M;map% Lux/Monad macro-expand expansion)] + (M;wrap (:: List/Monad (M;join expansion')))) + + #;None + (do Lux/Monad + [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) + + (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + (do Lux/Monad + [harg+ (macro-expand harg) + targs+ (M;map% Lux/Monad macro-expand targs)] + (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) + + (#;Meta [_ (#;TupleS members)]) + (do Lux/Monad + [members' (M;map% Lux/Monad macro-expand members)] + (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) + + _ + (:: Lux/Monad (M;wrap (list syntax))))) + +(def #export (gensym prefix state) + (-> Text (Lux Syntax)) + (#;Right [(update@ #;seed inc state) + (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) + +(def #export (emit datum) + (All [a] + (-> a (Lux a))) + (lambda [state] + (#;Right [state datum]))) + +(def #export (fail msg) + (All [a] + (-> Text (Lux a))) + (lambda [_] + (#;Left msg))) + +(def #export (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux/Monad + [token+ (macro-expand token)] + (case token+ + (\ (list token')) + (M;wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def #export (module-exists? module state) + (-> Text (Lux Bool)) + (#;Right [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)])) + +(def #export (exported-defs module state) + (-> Text (Lux (List Text))) + (case (get module (get@ #;modules state)) + (#;Some =module) + (using List/Monad + (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (get@ #;defs =module))))])) + + #;None + (#;Left ($ text:++ "Unknown module: " module)))) + +(def (show-envs envs) + (-> (List (Env Text (, LuxVar Type))) Text) + (|> envs + (F;map (lambda [env] + (case env + {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} + ($ text:++ name ": " (|> locals + (F;map (: (All [a] (-> (, Text a) Text)) + (lambda [b] (let [[label _] b] label)))) + (:: List/Functor) + (interpose " ") + (foldL text:++ "")))))) + (:: List/Functor) + (interpose "\n") + (foldL text:++ ""))) + +(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 (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 #;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 + closure)))) + envs)))) + +(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 #;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 #export (find-var-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (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 #;eval? eval?} state] + (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + )) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux new file mode 100644 index 000000000..22aeaf874 --- /dev/null +++ b/source/lux/meta/macro.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Utils] +(def (_meta x) + (-> (Syntax' (Meta Cursor)) Syntax) + (#;Meta [["" -1 -1] x])) + +## [Syntax] +(def #export (defmacro tokens state) + Macro + (case tokens + (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + _ + (#;Left "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +## [Functions] +(do-template [ ] + [(def #export ( x) + (-> Syntax) + (#;Meta [["" -1 -1] ( x)]))] + + [bool$ Bool #;BoolS] + [int$ Int #;IntS] + [real$ Real #;RealS] + [char$ Char #;CharS] + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS] + [tag$ Ident #;TagS] + [form$ (List Syntax) #;FormS] + [tuple$ (List Syntax) #;TupleS] + [record$ (List (, Syntax Syntax)) #;RecordS] + ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux new file mode 100644 index 000000000..1fe85c32f --- /dev/null +++ b/source/lux/meta/syntax.lux @@ -0,0 +1,262 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (macro #as m #refer #all) + (lux #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) + (char #as c) + (text #as t) + list))) + +## [Utils] +(def (first xy) + (All [a b] (-> (, a b) a)) + (let [[x y] xy] + x)) + +(def (join-pairs pairs) + (All [a] (-> (List (, a a)) (List a))) + (case pairs + #;Nil #;Nil + (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + +## Types +(deftype #export (Parser a) + (-> (List Syntax) (Maybe (, (List Syntax) a)))) + +## Structures +(defstruct #export Parser/Functor (F;Functor Parser) + (def (F;map f ma) + (lambda [tokens] + (case (ma tokens) + #;None + #;None + + (#;Some [tokens' a]) + (#;Some [tokens' (f a)]))))) + +(defstruct #export Parser/Monad (M;Monad Parser) + (def M;_functor Parser/Functor) + + (def (M;wrap x tokens) + (#;Some [tokens x])) + + (def (M;join mma) + (lambda [tokens] + (case (mma tokens) + #;None + #;None + + (#;Some [tokens' ma]) + (ma tokens'))))) + +## Parsers +(def #export (id^ tokens) + (Parser Syntax) + (case tokens + #;Nil #;None + (#;Cons [t tokens']) (#;Some [tokens' t]))) + +(do-template [ ] + [(def #export ( tokens) + (Parser ) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [ bool^ Bool #;BoolS] + [ int^ Int #;IntS] + [ real^ Real #;RealS] + [ char^ Char #;CharS] + [ text^ Text #;TextS] + [symbol^ Ident #;SymbolS] + [ tag^ Ident #;TagS] + ) + +(do-template [ ] + [(def #export ( tokens) + (Parser Text) + (case tokens + (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [local-symbol^ #;SymbolS] + [ local-tag^ #;TagS] + ) + +(def (ident:= x y) + (-> Ident Ident Bool) + (let [[x1 x2] x + [y1 y2] y] + (and (text:= x1 y1) + (text:= x2 y2)))) + +(do-template [ ] + [(def #export ( v tokens) + (-> (Parser (,))) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (if ( v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] + [ int?^ Int #;IntS i=] + [ real?^ Real #;RealS r=] + [ char?^ Char #;CharS (:: c;Char/Eq E;=)] + [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [symbol?^ Ident #;SymbolS ident:=] + [ tag?^ Ident #;TagS ident:=] + ) + +(do-template [ ] + [(def #export ( p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [(#;Meta [_ ( form)]) tokens']) + (case (p form) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None))] + + [ form^ #;FormS] + [tuple^ #;TupleS] + ) + +(def #export (?^ p tokens) + (All [a] + (-> (Parser a) (Parser (Maybe a)))) + (case (p tokens) + #;None (#;Some [tokens #;None]) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) + +(def (run-parser p tokens) + (All [a] + (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (p tokens)) + +(def #export (*^ p tokens) + (All [a] + (-> (Parser a) (Parser (List a)))) + (case (p tokens) + #;None (#;Some [tokens (list)]) + (#;Some [tokens' x]) (run-parser (do Parser/Monad + [xs (*^ p)] + (M;wrap (list& x xs))) + tokens'))) + +(def #export (+^ p) + (All [a] + (-> (Parser a) (Parser (List a)))) + (do Parser/Monad + [x p + xs (*^ p)] + (M;wrap (list& x xs)))) + +(def #export (&^ p1 p2) + (All [a b] + (-> (Parser a) (Parser b) (Parser (, a b)))) + (do Parser/Monad + [x1 p1 + x2 p2] + (M;wrap [x1 x2]))) + +(def #export (|^ p1 p2 tokens) + (All [a b] + (-> (Parser a) (Parser b) (Parser (Either b)))) + (case (p1 tokens) + (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) + #;None (run-parser (do Parser/Monad + [x2 p2] + (M;wrap (#;Right x2))) + tokens))) + +(def #export (||^ ps tokens) + (All [a] + (-> (List (Parser a)) (Parser (Maybe a)))) + (case ps + #;Nil #;None + (#;Cons [p ps']) (case (p tokens) + #;None (||^ ps' tokens) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) + )) + +(def #export (end^ tokens) + (Parser (,)) + (case tokens + #;Nil (#;Some [tokens []]) + _ #;None)) + +## Syntax +(defmacro #export (defsyntax tokens) + (let [[exported? tokens] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens]))] + (case tokens + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + body)) + (do Lux/Monad + [names+parsers (M;map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [arg] + (case arg + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) + (M;wrap [(symbol$ var-name) parser]) + + (\ (#;Meta [_ (#;SymbolS var-name)])) + (M;wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) + g!tokens (gensym "tokens") + g!_ (gensym "_") + #let [names (:: List/Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body name+parser] + (let [[name parser] name+parser] + (` (_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) + + (~ g!_) + (l;fail (~ error-msg))))))) + body + (reverse names+parsers)) + macro-def (: Syntax + (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) + + _ + (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/program.lux b/source/program.lux new file mode 100644 index 000000000..052c0bf41 --- /dev/null +++ b/source/program.lux @@ -0,0 +1,48 @@ +## 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 (codata (stream #as S)) + (control monoid + functor + monad + lazy + comonad) + (data bool + bounded + char + ## cont + dict + (either #as e) + eq + error + id + io + list + maybe + number + ord + (reader #as r) + show + state + (text #as t) + writer) + (host java) + (meta lux + macro + syntax) + (math #as m) + )) + +(program args + (case args + #;Nil + (println "Hello, world!") + + (#;Cons [name _]) + (println ($ text:++ "Hello, " name "!")))) -- cgit v1.2.3 From 9b7cfd6f5bcc93e2f2f0c3129b7ec6d62c69bb37 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Jul 2015 20:57:21 -0400 Subject: - Fixed a pattern-matching error where generalizations of types (universal-quantification / AllT) was not being taken into account properly when destructuring. - Fixed a compiler error wherein the types of definitions didn't generate (correctly) the structures necessary for storage inside the class _meta(data) field. - Improved both the "open" and "import" macros with extra features. --- source/lux.lux | 117 ++++++++++++++++++++++++++++++--------------- source/lux/data/char.lux | 3 +- source/lux/data/io.lux | 3 +- source/lux/data/number.lux | 8 ++-- source/lux/host/java.lux | 84 ++++++++++++++++---------------- source/lux/meta/lux.lux | 7 +-- source/lux/meta/syntax.lux | 2 +- source/program.lux | 2 +- 8 files changed, 133 insertions(+), 93 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 50f8f1af2..8f7e4fa04 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1069,7 +1069,7 @@ _ #Nil)) -(def'' #export (text:= x y) +(def'' (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y])) @@ -1196,7 +1196,7 @@ (-> Bool Bool) (if x false true)) -(def'' #export (text:++ x y) +(def'' (text:++ x y) (-> Text Text Text) (_jvm_invokevirtual java.lang.String concat [java.lang.String] x [y])) @@ -1883,8 +1883,11 @@ (#Exclude (List Text)) #Nothing)) +(deftype Openings + (, Text (List Ident))) + (deftype Import - (, Text (Maybe Text) Referrals)) + (, Text (Maybe Text) Referrals (Maybe Openings))) (def (extract-defs defs) (-> (List Syntax) (Lux (List Text))) @@ -1932,6 +1935,26 @@ _ (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) +(def (extract-symbol syntax) + (-> Syntax (Lux Ident)) + (case syntax + (#Meta [_ (#SymbolS ident)]) + (return ident) + + _ + (fail "Not a symbol."))) + +(def (parse-openings tokens) + (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (do Lux/Monad + [structs' (map% Lux/Monad extract-symbol structs)] + (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + + _ + (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) + (def (decorate-imports super-name tokens) (-> Text (List Syntax) (Lux (List Syntax))) (map% Lux/Monad @@ -1951,33 +1974,31 @@ (def (parse-imports imports) (-> (List Syntax) (Lux (List Import))) (do Lux/Monad - [referrals' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) - (lambda [token] - (case token - (#Meta [_ (#SymbolS ["" m-name])]) - (;return (list [m-name #None #All])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) - (do Lux/Monad - [alias+extra' (parse-alias extra) - #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) - alias+extra')] - referral+extra'' (parse-referrals extra') - #let [[referral extra''] (: (, Referrals (List Syntax)) - referral+extra'')] - extra''' (decorate-imports m-name extra'') - sub-imports (parse-imports extra''')] - (;return (case referral - #Nothing (case alias - #None sub-imports - (#Some _) (list& [m-name alias referral] sub-imports)) - _ (list& [m-name alias referral] sub-imports)))) - - _ - (fail "Wrong syntax for import")))) - imports)] - (;return (list:join referrals')))) + [imports' (map% Lux/Monad + (: (-> Syntax (Lux (List Import))) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" m-name])]) + (;return (list [m-name #None #All #None])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (do Lux/Monad + [alias+extra (parse-alias extra) + #let [[alias extra] alias+extra] + referral+extra (parse-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-openings extra) + #let [[openings extra] openings+extra] + extra (decorate-imports m-name extra) + sub-imports (parse-imports extra)] + (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) + [#Nothing #None #None] sub-imports + _ (list& [m-name alias referral openings] sub-imports)))) + + _ + (fail "Wrong syntax for import")))) + imports)] + (;return (list:join imports')))) (def (module-exists? module state) (-> Text (Lux Bool)) @@ -2131,16 +2152,16 @@ (: (-> Import (Lux Import)) (lambda [import] (case import - [m-name m-alias m-referrals] + [m-name m-alias m-referrals m-openings] (do Lux/Monad [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals])))))) + (;return (: Import [m-name m-alias m-referrals m-openings])))))) imports) unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) (lambda [import] (case import - [m-name _ _] + [m-name _ _ _] (do Lux/Monad [? (module-exists? m-name)] (;return (if ? @@ -2155,7 +2176,7 @@ (: (-> Import (Lux (List Syntax))) (lambda [import] (case import - [m-name m-alias m-referrals] + [m-name m-alias m-referrals m-openings] (do Lux/Monad [defs (case m-referrals #All @@ -2172,7 +2193,18 @@ (;return (filter (. not (is-member? -defs)) *defs))) #Nothing - (;return (list)))] + (;return (list))) + #let [openings (: (List Syntax) + (case m-openings + #None + (list) + + (#Some [prefix structs]) + (map (: (-> Ident Syntax) + (lambda [struct] + (let [[_ name] struct] + (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) + structs)))]] (;return ($ list:++ (list (` (_lux_import (~ (text$ m-name))))) (case m-alias @@ -2181,7 +2213,8 @@ (map (: (-> Text Syntax) (lambda [def] (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs))))))) + defs) + openings)))))) imports)] (;return (list:join output'))) @@ -2583,16 +2616,22 @@ (defmacro #export (open tokens) (case tokens - (\ (list (#Meta [_ (#SymbolS struct-name)]))) + (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens')) (do Lux/Monad - [struct-type (find-var-type struct-name)] + [#let [prefix (case tokens' + (\ (list (#Meta [_ (#TextS prefix)]))) + prefix + + _ + "")] + struct-type (find-var-type struct-name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) (return (map (: (-> (, Text Type) Syntax) (lambda [slot] (let [[sname stype] slot [module name] (split-slot sname)] - (` (_lux_def (~ (symbol$ ["" name])) + (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) slots)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 42e57509e..5dac9a3c7 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -8,7 +8,8 @@ (;import lux (.. (eq #as E) - (show #as S))) + (show #as S) + (text #as T #open ("text:" Text/Monoid)))) ## [Structures] (defstruct #export Char/Eq (E;Eq Char) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index c08023df5..17e8d727a 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -10,7 +10,8 @@ (lux/meta macro) (lux/control (functor #as F) (monad #as M)) - lux/data/list) + (.. list + (text #as T #open ("text:" Text/Monoid)))) ## Types (deftype #export (IO a) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux index 8da674d88..b222de15c 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number.lux @@ -8,10 +8,10 @@ (;import lux (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) + (.. (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) ## Signatures (defsig #export (Number n) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux index 12525d3f2..9bd0c838c 100644 --- a/source/lux/host/java.lux +++ b/source/lux/host/java.lux @@ -10,14 +10,12 @@ (lux (control (monoid #as m) (functor #as F) (monad #as M #refer (#only do))) - (data list + (data (list #as l #refer #all #open ("" List/Functor)) (text #as text)) (meta lux macro syntax))) -## (open List/Functor) - ## [Utils/Parsers] (def finally^ (Parser Syntax) @@ -110,29 +108,29 @@ (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) (emit (list (` (_jvm_try (~ body) - (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches)) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally)))))))))))) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (do Lux/Monad [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name))]] - (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - members))] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] (~@ members')))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] @@ -142,35 +140,35 @@ [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name)) - fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - fields)) - methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs)))] - (~ (text$ output)) - [(~@ (:: List/Functor (F;map text$ modifiers)))] - (~ body)))))) - methods))]] + fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))))) + fields) + methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ (map text$ interfaces))] [(~@ fields')] [(~@ methods')])))))) (defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ (map text$ arg-classes))] [(~@ args)]))))) (defsyntax #export (instance? [class local-symbol^] obj) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index a28d6e5d4..99ca200cf 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -14,7 +14,8 @@ (lux/data list maybe (show #as S) - (number #as N))) + (number #as N) + (text #as T #open ("text:" Text/Monoid Text/Eq)))) ## [Types] ## (deftype (Lux a) @@ -209,10 +210,10 @@ (lambda [b] (let [[label _] b] label)))) (:: List/Functor) (interpose " ") - (foldL text:++ "")))))) + (foldL text:++ text:unit)))))) (:: List/Functor) (interpose "\n") - (foldL text:++ ""))) + (foldL text:++ text:unit))) (def (try-both f x1 x2) (All [a b] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 1fe85c32f..83702f75d 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -14,7 +14,7 @@ (data (eq #as E) (bool #as b) (char #as c) - (text #as t) + (text #as t #open ("text:" Text/Monoid Text/Eq)) list))) ## [Utils] diff --git a/source/program.lux b/source/program.lux index 052c0bf41..18a2a76ab 100644 --- a/source/program.lux +++ b/source/program.lux @@ -30,7 +30,7 @@ (reader #as r) show state - (text #as t) + (text #as t #open ("text:" Text/Monoid)) writer) (host java) (meta lux -- cgit v1.2.3 From 8fb7683f9029127be9cf36336c367813c88f681b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Jul 2015 23:09:47 -0400 Subject: - Changed the name of lux/host/java to lux/host/jvm - Completed lux/host/jvm - Modified (slightly) the syntax used in several host (JVM) special forms. - The "defsyntax" macro now binds all of the arguments it receives inside a variable named "tokens". --- source/lux.lux | 27 ++-- source/lux/data/char.lux | 2 +- source/lux/data/io.lux | 4 +- source/lux/data/number.lux | 14 +- source/lux/data/text.lux | 61 ++++----- source/lux/host/java.lux | 310 --------------------------------------------- source/lux/host/jvm.lux | 270 +++++++++++++++++++++++++++++++++++++++ source/lux/math.lux | 50 ++++---- source/lux/meta/syntax.lux | 2 +- source/program.lux | 2 +- 10 files changed, 346 insertions(+), 396 deletions(-) delete mode 100644 source/lux/host/java.lux create mode 100644 source/lux/host/jvm.lux (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 8f7e4fa04..c51929635 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -8,7 +8,7 @@ ## First things first, must define functions (_jvm_interface "Function" [] - (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) ## Basic types (_lux_def Bool (#DataT "java.lang.Boolean")) @@ -860,8 +860,9 @@ [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] unquoted - [_ (#Meta [_ (#FormS elems)])] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + [_ (#Meta [meta (#FormS elems)])] + (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"]) @@ -1071,7 +1072,7 @@ (def'' (text:= x y) (-> Text Text Bool) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y])) (def'' (get-rep key env) @@ -1146,9 +1147,9 @@ (-> Bool) ( x y))] - [i= _jvm_leq Int] - [i> _jvm_lgt Int] - [i< _jvm_llt Int] + [i= _jvm_leq Int] + [i> _jvm_lgt Int] + [i< _jvm_llt Int] [r= _jvm_deq Real] [r> _jvm_dgt Real] [r< _jvm_dlt Real] @@ -1198,7 +1199,7 @@ (def'' (text:++ x y) (-> Text Text Text) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] + (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y])) (def'' (ident->text ident) @@ -1396,7 +1397,7 @@ (def'' #export (->text x) (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual java.lang.Object toString [] x [])) + (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) (def'' (interpose sep xs) (All [a] @@ -2039,22 +2040,22 @@ (def (last-index-of part text) (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String] + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] text [part]))) (def (index-of part text) (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] text [part]))) (def (substring1 idx text) (-> Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int] + (_jvm_invokevirtual "java.lang.String" "substring" ["int"] text [(_jvm_l2i idx)])) (def (substring2 idx1 idx2 text) (-> Int Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int int] + (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) (def (split-module-contexts module) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 5dac9a3c7..5a811c006 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -18,4 +18,4 @@ (defstruct #export Char/Show (S;Show Char) (def (S;show x) - ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) + ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 17e8d727a..a194fc854 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -44,8 +44,8 @@ ## Functions (def #export (print x) (-> Text (IO (,))) - (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x]))) + (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.Object"] + (_jvm_getstatic "java.lang.System" "out") [x]))) (def #export (println x) (-> Text (IO (,))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux index b222de15c..453c30a13 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number.lux @@ -62,12 +62,6 @@ (def E;= r=)) ## Ord -## (def #export Int/Ord (O;Ord Int) -## (O;ord$ Int/Eq i< i>)) - -## (def #export Real/Ord (O;Ord Real) -## (O;ord$ Real/Eq r< r>)) - (do-template [ ] [(defstruct #export (O;Ord ) (def O;_eq ) @@ -89,8 +83,8 @@ (def B;top ) (def B;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)]) + [ 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 [ <++>] @@ -114,6 +108,6 @@ (def (S;show x) ))] - [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] + [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] ) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index a3192a1d5..f7f1a86c0 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -15,30 +15,30 @@ ## [Functions] (def #export (size x) (-> Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "length" [] x []))) (def #export (@ idx x) (-> Int Text (Maybe Char)) (if (and (i< idx (size x)) (i>= idx 0)) - (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + (#;Some (_jvm_invokevirtual "java.lang.String" "charAt" ["int"] x [(_jvm_l2i idx)])) #;None)) (def #export (contains? x y) (-> Text Text Bool) - (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] + (_jvm_invokevirtual "java.lang.String" "contains" ["java.lang.CharSequence"] x [y])) (do-template [ ] [(def #export ( x) (-> Text Text) - (_jvm_invokevirtual java.lang.String [] + (_jvm_invokevirtual "java.lang.String" [] x []))] - [lower-case toLowerCase] - [upper-case toUpperCase] - [trim trim] + [lower-case "toLowerCase"] + [upper-case "toUpperCase"] + [trim "trim"] ) (def #export (sub' from to x) @@ -46,7 +46,7 @@ (if (and (i< from to) (i>= from 0) (i<= to (size x))) - (_jvm_invokevirtual java.lang.String substring [int int] + (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] x [(_jvm_l2i from) (_jvm_l2i to)]) #;None)) @@ -58,23 +58,23 @@ (-> Int Text (Maybe (, Text Text))) (if (and (i< at (size x)) (i>= at 0)) - (let [pre (_jvm_invokevirtual java.lang.String substring [int int] + (let [pre (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] x [(_jvm_l2i 0) (_jvm_l2i at)]) - post (_jvm_invokevirtual java.lang.String substring [int] + post (_jvm_invokevirtual "java.lang.String" "substring" ["int"] x [(_jvm_l2i at)])] (#;Some [pre post])) #;None)) (def #export (replace pattern value template) (-> Text Text Text Text) - (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] + (_jvm_invokevirtual "java.lang.String" "replace" ["java.lang.CharSequence" "java.lang.CharSequence"] template [pattern value])) (do-template [ ] [(def #export ( pattern from x) (-> Text Int Text (Maybe Int)) (if (and (i< from (size x)) (i>= from 0)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] + (case (_jvm_i2l (_jvm_invokevirtual "java.lang.String" ["java.lang.String" "int"] x [pattern (_jvm_l2i from)])) -1 #;None idx (#;Some idx)) @@ -82,13 +82,13 @@ (def #export ( pattern x) (-> Text Text (Maybe Int)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] + (case (_jvm_i2l (_jvm_invokevirtual "java.lang.String" ["java.lang.String"] x [pattern])) -1 #;None idx (#;Some idx)))] - [index-of index-of' indexOf] - [last-index-of last-index-of' lastIndexOf] + [index-of index-of' "indexOf"] + [last-index-of last-index-of' "lastIndexOf"] ) (def #export (starts-with? prefix x) @@ -113,27 +113,22 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) (def (E;= x y) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) (def O;_eq Text/Eq) - (def (O;< x y) - (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;<= x y) - (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;> x y) - (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;>= x y) - (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0))) + + (do-template [ ] + [(def ( x y) + ( (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "compareTo" ["java.lang.String"] + x [y])) + 0))] + + [O;< i<] + [O;<= i<=] + [O;> i>] + [O;>= i>=])) (defstruct #export Text/Show (S;Show Text) (def (S;show x) @@ -142,5 +137,5 @@ (defstruct #export Text/Monoid (m;Monoid Text) (def m;unit "") (def (m;++ x y) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] + (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux deleted file mode 100644 index 9bd0c838c..000000000 --- a/source/lux/host/java.lux +++ /dev/null @@ -1,310 +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 (control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do))) - (data (list #as l #refer #all #open ("" List/Functor)) - (text #as text)) - (meta lux - macro - syntax))) - -## [Utils/Parsers] -(def finally^ - (Parser Syntax) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "finally"]) - expr id^ - _ end^] - (M;wrap expr)))) - -(def catch^ - (Parser (, Text Ident Syntax)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^ - _ end^] - (M;wrap [ex-class ex expr])))) - -(def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^ - _ end^] - (M;wrap [modifiers name inputs output])))) - -(def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^ - _ end^] - (M;wrap [modifiers name class])))) - -(def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^ - _ end^] - (M;wrap [arg-name arg-class])))) - -(def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - body id^ - _ end^] - (M;wrap [modifiers name inputs output body])))) - -(def method-call^ - (Parser (, Text (List Text) (List Syntax))) - (form^ (do Parser/Monad - [method local-symbol^ - arity-classes (tuple^ (*^ local-symbol^)) - arity-args (tuple^ (*^ id^)) - _ end^ - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (M;wrap []) - (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) - ))) - -## [Utils/Lux] -## (def (find-class-field field class) -## (-> Text Text (Lux Type)) -## ...) - -## (def (find-virtual-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - -## (def (find-static-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - - -## [Syntax] -(defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) - -(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally))))))))))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] - (~@ members')))))))) - -(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [fields (*^ field-decl^)] - [methods (*^ method-def^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (map text$ modifiers))]))))) - fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) - -(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) - -(defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) - -(defsyntax #export (locking lock body) - (do Lux/Monad - [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitor-enter (~ g!lock)) - (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ g!lock))] - (~ g!body))))) - )) - -(defsyntax #export (null? obj) - (emit (list (` (_jvm_null? (~ obj)))))) - -(defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) - -## (defsyntax #export (.? [field local-symbol^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) - -## _ -## (fail "Can only get field from object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.? (~ field) (~ g!obj))))))))) - -## (defsyntax #export (.= [field local-symbol^] value obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) - -## _ -## (fail "Can only set field of object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.= (~ field) (~ value) (~ g!obj))))))))) - -## (defsyntax #export (.! [call method-call^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-virtual-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] -## (~ obj) [(~@ m-args)]))))) - -## _ -## (fail "Can only call method on object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.! (~@ *tokens*))))))))) - -## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) -## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) - -## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) -## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) - -## (defsyntax #export (..! [call method-call^] [class local-symbol^]) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-static-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) -## [(~@ (:: List/Functor (F;map text$ m-ins)))] -## [(~@ m-args)])))) -## )) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux new file mode 100644 index 000000000..a3a74d608 --- /dev/null +++ b/source/lux/host/jvm.lux @@ -0,0 +1,270 @@ +## 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) + (functor #as F) + (monad #as M #refer (#only do))) + (data (list #as l #refer #all #open ("" List/Functor)) + (text #as text)) + (meta lux + macro + syntax))) + +## [Utils] +## Parsers +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally))))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))))) + fields) + methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (map text$ arg-classes))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +(defsyntax #export (.? [field local-symbol^] obj) + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) + + _ + (fail "Can only get field from object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.? (~ (text$ field)) (~ g!obj))))))))) + +(defsyntax #export (.= [field local-symbol^] value obj) + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) + + _ + (fail "Can only set field of object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) + +(defsyntax #export (.! [call method-call^] obj) + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (let [[m-name ?m-classes m-args] call] + (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] + (~ obj) [(~@ m-args)]))))) + + _ + (fail "Can only call method on object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.! (~@ *tokens*))))))))) + +(defsyntax #export (..? [field local-symbol^] [class local-symbol^]) + (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +(defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) + (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +(defsyntax #export (..! [call method-call^] [class local-symbol^]) + (let [[m-name m-classes m-args] call] + (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) + [(~@ (map text$ m-classes))] + [(~@ m-args)])))))) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux index 2e29c5da7..8a9432261 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -12,49 +12,49 @@ (do-template [ ] [(def #export Real - (_jvm_getstatic java.lang.Math ))] + (_jvm_getstatic "java.lang.Math" ))] - [e E] - [pi PI] + [e "E"] + [pi "PI"] ) ## [Functions] (do-template [ ] [(def #export ( n) (-> Real Real) - (_jvm_invokestatic java.lang.Math [double] [n]))] + (_jvm_invokestatic "java.lang.Math" ["double"] [n]))] - [cos cos] - [sin sin] - [tan tan] + [cos "cos"] + [sin "sin"] + [tan "tan"] - [acos acos] - [asin asin] - [atan atan] + [acos "acos"] + [asin "asin"] + [atan "atan"] - [cosh cosh] - [sinh sinh] - [tanh tanh] + [cosh "cosh"] + [sinh "sinh"] + [tanh "tanh"] - [ceil ceil] - [floor floor] - [round round] + [ceil "ceil"] + [floor "floor"] + [round "round"] - [exp exp] - [log log] + [exp "exp"] + [log "log"] - [cbrt cbrt] - [sqrt sqrt] + [cbrt "cbrt"] + [sqrt "sqrt"] - [->degrees toDegrees] - [->radians toRadians] + [->degrees "toDegrees"] + [->radians "toRadians"] ) (do-template [ ] [(def #export ( x y) (-> Real Real Real) - (_jvm_invokestatic java.lang.Math [double double] [x y]))] + (_jvm_invokestatic "java.lang.Math" ["double" "double"] [x y]))] - [atan2 atan2] - [pow pow] + [atan2 "atan2"] + [pow "pow"] ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 83702f75d..fcee80b8f 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -235,7 +235,7 @@ _ (l;fail "Syntax pattern expects 2-tuples or symbols.")))) args) - g!tokens (gensym "tokens") + #let [g!tokens (m;symbol$ ["" "*tokens*"])] g!_ (gensym "_") #let [names (:: List/Functor (F;map first names+parsers)) error-msg (text$ (text:++ "Wrong syntax for " name)) diff --git a/source/program.lux b/source/program.lux index 18a2a76ab..37391eda9 100644 --- a/source/program.lux +++ b/source/program.lux @@ -32,7 +32,7 @@ state (text #as t #open ("text:" Text/Monoid)) writer) - (host java) + (host jvm) (meta lux macro syntax) -- cgit v1.2.3 From c79621772c862e9b94e1fc43e11996cbac54fed1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 29 Jul 2015 20:20:26 -0400 Subject: - lux;using no longer prefixes variables. - Fixed several bugs with host (JVM) interop. - Now packaging everything in a .jar file ("program.jar"). --- source/lux.lux | 4 +- source/lux/control/comonad.lux | 4 +- source/lux/control/monad.lux | 2 +- source/lux/data/list.lux | 2 +- source/lux/data/number.lux | 4 +- source/lux/data/text.lux | 4 +- source/lux/host/jvm.lux | 108 +++++++++++++++-------------------------- source/lux/math.lux | 5 +- source/lux/meta/lux.lux | 16 +++--- source/lux/meta/syntax.lux | 4 +- source/program.lux | 10 ++-- 11 files changed, 67 insertions(+), 96 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index c51929635..8861bc241 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -2524,8 +2524,8 @@ (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)]))) + [module name] (split-slot sname)] + [(tag$ [module name]) (symbol$ ["" name])]))) slots))] (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index 1830ff44f..ce9a7e7de 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -27,8 +27,8 @@ (All [w a b] (-> (CoMonad w) (-> (w a) b) (w a) (w b))) (using w - (using ;;_functor - (F;map f (;;split ma))))) + (using _functor + (map f (split ma))))) ## Syntax (defmacro #export (be tokens state) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index b5552f987..a03c1499a 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -82,7 +82,7 @@ (All [m a b] (-> (Monad m) (-> a (m b)) (m a) (m b))) (using m - (;;join (:: ;;_functor (F;map f ma))))) + (join (:: _functor (F;map f ma))))) (def #export (map% m f xs) (All [m a b] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 450dee275..8fd5c2951 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -247,4 +247,4 @@ (def (M;join mma) (using List/Monoid - (foldL m;++ m;unit mma)))) + (foldL ++ unit mma)))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux index 453c30a13..8771ef06e 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number.lux @@ -68,11 +68,11 @@ (def O;< ) (def (O;<= x y) (or ( x y) - (using (E;= x y)))) + (:: (E;= x y)))) (def O;> ) (def (O;>= x y) (or ( x y) - (using (E;= x y)))))] + (:: (E;= x y)))))] [ Int/Ord Int Int/Eq i< i>] [Real/Ord Real Real/Eq r< r>]) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index f7f1a86c0..6ad9cfd63 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -46,8 +46,8 @@ (if (and (i< from to) (i>= from 0) (i<= to (size x))) - (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - x [(_jvm_l2i from) (_jvm_l2i to)]) + (#;Some (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] + x [(_jvm_l2i from) (_jvm_l2i to)])) #;None)) (def #export (sub from x) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index a3a74d608..7af043969 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -22,8 +22,7 @@ (Parser Syntax) (form^ (do Parser/Monad [_ (symbol?^ ["" "finally"]) - expr id^ - _ end^] + expr id^] (M;wrap expr)))) (def catch^ @@ -32,8 +31,7 @@ [_ (symbol?^ ["" "catch"]) ex-class local-symbol^ ex symbol^ - expr id^ - _ end^] + expr id^] (M;wrap [ex-class ex expr])))) (def method-decl^ @@ -42,8 +40,7 @@ [modifiers (*^ local-tag^) name local-symbol^ inputs (tuple^ (*^ local-symbol^)) - output local-symbol^ - _ end^] + output local-symbol^] (M;wrap [modifiers name inputs output])))) (def field-decl^ @@ -51,16 +48,14 @@ (form^ (do Parser/Monad [modifiers (*^ local-tag^) name local-symbol^ - class local-symbol^ - _ end^] + class local-symbol^] (M;wrap [modifiers name class])))) (def arg-decl^ (Parser (, Text Text)) (form^ (do Parser/Monad [arg-name local-symbol^ - arg-class local-symbol^ - _ end^] + arg-class local-symbol^] (M;wrap [arg-name arg-class])))) (def method-def^ @@ -70,8 +65,7 @@ name local-symbol^ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ - body id^ - _ end^] + body id^] (M;wrap [modifiers name inputs output body])))) (def method-call^ @@ -80,7 +74,6 @@ [method local-symbol^ arity-classes (tuple^ (*^ local-symbol^)) arity-args (tuple^ (*^ id^)) - _ end^ _ (: (Parser (,)) (if (i= (size arity-classes) (size arity-args)) @@ -108,47 +101,41 @@ (list (` (_jvm_finally (~ finally))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] - (~@ members')))))))) + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ members'))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] [methods (*^ method-def^)]) (do Lux/Monad [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (map (: (-> (, (List Text) Text Text) Syntax) + #let [fields' (map (: (-> (, (List Text) Text Text) Syntax) (lambda [field] (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) + (` ((~ (text$ name)) (~ (text$ class)) [(~@ (map text$ modifiers))]))))) fields) methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) (lambda [methods] (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) + (` ((~ (text$ name)) [(~@ (map (: (-> (, Text Text) Syntax) (lambda [in] (let [[left right] in] - (form$ (list (text$ left) + (form$ (list (symbol$ ["" left]) (text$ right)))))) inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))] (~ body)))))) methods)]] - (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) [(~@ (map text$ interfaces))] [(~@ fields')] [(~@ methods')])))))) @@ -166,9 +153,9 @@ [g!lock (gensym "") g!body (gensym "")] (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitor-enter (~ g!lock)) + _ (_jvm_monitorenter (~ g!lock)) (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ g!lock))] + _ (_jvm_monitorexit (~ g!lock))] (~ g!body))))) )) @@ -216,24 +203,27 @@ (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) (defsyntax #export (.! [call method-call^] obj) - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (let [[m-name ?m-classes m-args] call] + (let [[m-name ?m-classes m-args] call] + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)]))))) + (~ obj) [(~@ m-args)])))) - _ - (fail "Can only call method on object."))) + _ + (fail "Can only call method on object."))) - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.! (~@ *tokens*))))))))) + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.! ((~ (symbol$ ["" m-name])) + [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] + [(~@ m-args)]) + (~ g!obj)))))))))) (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) @@ -246,25 +236,3 @@ (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ m-classes))] [(~@ m-args)])))))) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux index 8a9432261..a495d130c 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -38,7 +38,6 @@ [ceil "ceil"] [floor "floor"] - [round "round"] [exp "exp"] [log "log"] @@ -50,6 +49,10 @@ [->radians "toRadians"] ) +(def #export (round n) + (-> Real Int) + (_jvm_invokestatic "java.lang.Math" "round" ["double"] [n])) + (do-template [ ] [(def #export ( x y) (-> Real Real Real) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 99ca200cf..19b7dd9df 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -187,14 +187,14 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (get@ #;defs =module))))])) + (#;Right [state (join (:: _functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (get@ #;defs =module))))])) #;None (#;Left ($ text:++ "Unknown module: " module)))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index fcee80b8f..63ab81475 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -235,7 +235,7 @@ _ (l;fail "Syntax pattern expects 2-tuples or symbols.")))) args) - #let [g!tokens (m;symbol$ ["" "*tokens*"])] + g!tokens (gensym "tokens") g!_ (gensym "_") #let [names (:: List/Functor (F;map first names+parsers)) error-msg (text$ (text:++ "Wrong syntax for " name)) @@ -249,7 +249,7 @@ (~ g!_) (l;fail (~ error-msg))))))) body - (reverse names+parsers)) + (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) macro-def (: Syntax (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body'))))]] diff --git a/source/program.lux b/source/program.lux index 37391eda9..086506725 100644 --- a/source/program.lux +++ b/source/program.lux @@ -41,8 +41,8 @@ (program args (case args - #;Nil - (println "Hello, world!") - - (#;Cons [name _]) - (println ($ text:++ "Hello, " name "!")))) + (\ (list name)) + (println ($ text:++ "Hello, " name "!")) + + _ + (println "Hello, world!"))) -- cgit v1.2.3