diff options
| author | Eduardo Julian | 2015-04-28 01:18:39 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2015-04-28 01:18:39 -0400 |
| commit | ccf68d96c9c9e6bb6016ee8663289c3b3f6079d2 (patch) | |
| tree | 2414da60809b2c9e68ca3012271b30cc842d3805 /source | |
| parent | 5046f872d28edfab44e5efb0e200e49267832b49 (diff) | |
- Fixed some errors in lux.lux.
- Added the ability to export from def.
- Added an optimized lambda macro.
- Finished record analysis & compilation.
- Fixed a bug in tuple, function & record analysis wherein AppT wasn't being performed prior to analysing the expression under analysis.
- Fixed several bugs wherein "fail*" was needed but "fail" was used.
- Added a case for records in base;show-ast.
- Made an improvement for AllT in type;show-type.
- Corrected an error in pattern-matching compilation wherein casts weren't being performed to make sure the source datum was of the necessary type for PM.
- Removed the (now unnecessary) lux/macro.
Diffstat (limited to 'source')
| -rw-r--r-- | source/lux.lux | 2396 |
1 files changed, 1294 insertions, 1102 deletions
diff --git a/source/lux.lux b/source/lux.lux index 36e678886..973d5727b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -77,15 +77,14 @@ ## (& #counter Int ## #mappings (List (, k v)))) (def' Bindings - (:' Type - (#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 @@ -93,42 +92,38 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (def' Env - (:' Type - (#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)) (def' Cursor - (:' Type - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))) + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (def' Meta - (:' Type - (#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]))])])) (export' Meta) ## (def' Reader ## (List (Meta Cursor Text))) (def' Reader - (:' Type - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])]))) + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) (export' Reader) ## (deftype HostState @@ -136,11 +131,10 @@ ## #loader (^ java.net.URLClassLoader) ## #eval-ctor Int)) (def' HostState - (:' Type - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;eval-ctor" Int] - #Nil])])])))) + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + (#Cons [["lux;eval-ctor" Int] + #Nil])])]))) ## (deftype CompilerState ## (& #source (Maybe Reader) @@ -150,14 +144,13 @@ ## #types (Bindings Int Type) ## #host HostState)) (def' CompilerState - (:' Type - (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] - (#Cons [["lux;modules" (#AppT [List Void])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) Void])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - #Nil])])])])])])))) + (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] + (#Cons [["lux;modules" (#AppT [List Void])] + (#Cons [["lux;module-aliases" (#AppT [List Void])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) Void])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + #Nil])])])])])]))) (export' CompilerState) ## (deftype (Syntax' w) @@ -170,41 +163,39 @@ ## (#Tag (, Text Text)) ## (#Form (List (w (Syntax' w)))) ## (#Tuple (List (w (Syntax' w)))) -## (#Record (List (, Text (w (Syntax' w))))))) +## (#Record (List (, (w (Syntax' w)) (w (Syntax' w))))))) (def' Syntax' - (:' Type - (case' (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") - (#BoundT "w")])]) - Syntax' - (case' (#AppT [List Syntax']) - Syntax'List - (case' (#TupleT (#Cons [Text (#Cons [Text #Nil])])) - Ident - (#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" Syntax'List] - (#Cons [["lux;Tuple" Syntax'List] - (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax' #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )]) - ))))) + (case' (#AppT [(#BoundT "w") + (#AppT [(#BoundT "Syntax'") + (#BoundT "w")])]) + Syntax' + (case' (#AppT [List Syntax']) + Syntax'List + (case' (#TupleT (#Cons [Text (#Cons [Text #Nil])])) + Ident + (#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" Syntax'List] + (#Cons [["lux;Tuple" Syntax'List] + (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax' #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )]) + )))) (export' Syntax') ## (deftype Syntax ## (Meta Cursor (Syntax' (Meta Cursor)))) (def' Syntax - (:' Type - (case' (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])])))) + (case' (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) (export' Syntax) (def' SyntaxList (#AppT [List Syntax])) @@ -213,25 +204,23 @@ ## (| (#Left l) ## (#Right r))) (def' Either - (:' Type - (#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])]))])])) (export' Either) ## (deftype Macro ## (-> (List Syntax) CompilerState ## (Either Text (, CompilerState (List Syntax))))) (def' Macro - (:' Type - (#LambdaT [SyntaxList - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [SyntaxList - #Nil])]))])])]))) + (#LambdaT [SyntaxList + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [SyntaxList + #Nil])]))])])])) (export' Macro) ## Base functions & macros @@ -279,17 +268,40 @@ (lambda' _ state (#Left msg))))) -## (def' let' -## (:' Macro -## (lambda' _ tokens -## (case' tokens -## (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) -## (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"])) -## (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))) -## #Nil])) +(def' Ident + (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(export' Ident) + +(def' $text + (:' (#LambdaT [Text Syntax]) + (lambda' _ text + (_meta (#Text text))))) +(export' $text) + +(def' $symbol + (:' (#LambdaT [Ident Syntax]) + (lambda' _ ident + (_meta (#Symbol ident))))) +(export' $symbol) + +(def' $tag + (:' (#LambdaT [Ident Syntax]) + (lambda' _ ident + (_meta (#Tag ident))))) +(export' $tag) + +(def' $form + (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) + (lambda' _ tokens + (_meta (#Form tokens))))) +(export' $form) + +(def' $tuple + (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) + (lambda' _ tokens + (_meta (#Tuple tokens))))) +(export' $tuple) -## _ -## (#Left "Wrong syntax for let'"))))) (def' let' (:' Macro (lambda' _ tokens @@ -303,7 +315,7 @@ _ (fail "Wrong syntax for let'"))))) -(def' lambda +(def' lambda_ (:' Macro (lambda' _ tokens (case' tokens @@ -317,7 +329,7 @@ body _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"])) + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) (#Cons [(_meta (#Tuple args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -333,7 +345,7 @@ body _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"])) + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) (#Cons [(_meta (#Tuple args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -341,80 +353,99 @@ _ (fail "Wrong syntax for lambda"))))) -(export' lambda) -(def' def +(def' def_ (:' Macro - (lambda [tokens] + (lambda_ [tokens] (case' tokens - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) tokens]))) - #Nil]))) - - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) - (#Cons [body #Nil])]) + (#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 [(_meta (#Symbol name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"])) - (#Cons [(_meta (#Symbol name)) - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) + (#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 [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) + #Nil])]))) - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type (#Cons [body #Nil])])]) + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [(_meta (#Symbol name)) + (#Cons [name (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type (#Cons [body #Nil])])]))) #Nil])])]))) - #Nil]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) + #Nil])]))) - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [(_meta (#Symbol name)) + (#Cons [name (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"])) - (#Cons [(_meta (#Symbol name)) + (#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]))) + _ (fail "Wrong syntax for def") )))) -(export' def) -(def (defmacro tokens) +(def_ #export (defmacro tokens) Macro (case' tokens - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol fn-name)]) args]))]) - (#Cons [body #Nil])]) + (#Cons [usage (#Cons [body #Nil])]) (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "def"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol fn-name)) args]))) - (#Cons [(_meta (#Symbol ["lux" "Macro"])) + (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"]) + (#Cons [usage + (#Cons [($symbol ["lux" "Macro"]) (#Cons [body #Nil])]) ])]))) #Nil]))) + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [usage (#Cons [body #Nil])])]) + (return (:' SyntaxList + (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($tag ["" "export"]) + (#Cons [usage + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])]))) + #Nil]))) + _ (fail "Wrong syntax for defmacro"))) -(defmacro (comment tokens) +(defmacro #export (comment tokens) (return (:' SyntaxList #Nil))) -(export' comment) (defmacro (->' tokens) (case' tokens @@ -494,7 +525,7 @@ _ (fail "Wrong syntax for $'"))) -(def (fold f init xs) +(def_ #export (fold f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -507,42 +538,119 @@ (#Cons [x xs']) (fold f (f init x) xs'))) -(def (reverse list) +(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]))) + (lambda_ [tail head] + (#Cons [head tail]))) #Nil list)) -(defmacro (list xs) +(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])]))))) + (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])))) -(export' list) -(defmacro (list& xs) +(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)))))))) + (lambda_ [tail head] + (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) + (_meta (#Tuple (list head tail)))))))) last init)))) _ (fail "Wrong syntax for list&"))) -(export' 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]) + (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'))))))) + + _ + (fail "Wrong syntax for lambda")))) + +(defmacro #export (def tokens) + (case' tokens + (#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))))) + + (#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))))) + + (#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))))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (:' SyntaxList + (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) type body))))))) + + _ + (fail "Wrong syntax for def") + )) (def (as-pairs xs) (All' [a] @@ -554,7 +662,7 @@ _ #Nil)) -(defmacro (let tokens) +(defmacro #export (let tokens) (case' tokens (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) (return (:' SyntaxList @@ -574,9 +682,8 @@ _ (fail "Wrong syntax for let"))) -(export' let) -(def (map f xs) +(def #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (case' xs @@ -586,11 +693,32 @@ (#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 + + (#Cons [x xs']) + (case' (p x) + true true + false (any? p xs')))) + +(def (spliced? token) + (->' Syntax Bool) + (case' token + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) + true + + _ + false)) + (def (wrap-meta content) - (->' ($' Syntax' ($' Meta Cursor)) Syntax) + (->' Syntax Syntax) (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1))))) - (_meta content)))))))) + content))))))) (def (untemplate-list tokens) (->' ($' List Syntax) Syntax) @@ -602,48 +730,110 @@ (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list token (untemplate-list tokens'))))))))) +## (def (untemplate token) +## (->' Syntax Syntax) +## (case' token +## (#Meta [_ (#Bool value)]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value))))) + +## (#Meta [_ (#Int value)]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value))))) + +## (#Meta [_ (#Real value)]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value))))) + +## (#Meta [_ (#Char value)]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value))))) + +## (#Meta [_ (#Text value)]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value))))) + +## (#Meta [_ (#Tag [module name])]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) + +## (#Meta [_ (#Symbol [module name])]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) + +## (#Meta [_ (#Tuple elems)]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tuple"])) (untemplate-list (map untemplate elems))))) + +## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [(#Meta [_ unquoted]) #Nil])]))]) +## (_meta unquoted) + +## (#Meta [_ (#Form elems)]) +## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Form"])) (untemplate-list (map untemplate elems))))) + +## (#Meta [_ (#Record fields)]) +## (wrap-meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax))) +## (lambda [kv] +## (let [[k v] kv] +## [k (untemplate v)]))) +## fields))) +## )) + +(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 + + _ + (_meta (#Form (list ($symbol ["lux" "list"]) elem)))))) + elems)] + (wrap-meta ($form (list tag + (wrap-meta ($form (list& ($tag ["lux" "$"]) + ($tag ["lux" "list:++"]) + elems'))))))) + + false + (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) + (def (untemplate token) (->' Syntax Syntax) (case' token (#Meta [_ (#Bool value)]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value))))) + (wrap-meta ($form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value))))) (#Meta [_ (#Int value)]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value))))) + (wrap-meta ($form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value))))) (#Meta [_ (#Real value)]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value))))) + (wrap-meta ($form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value))))) (#Meta [_ (#Char value)]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value))))) + (wrap-meta ($form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value))))) (#Meta [_ (#Text value)]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value))))) + (wrap-meta ($form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value))))) (#Meta [_ (#Tag [module name])]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) + (wrap-meta ($form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) (#Meta [_ (#Symbol [module name])]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) + (wrap-meta ($form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) (#Meta [_ (#Tuple elems)]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tuple"])) (untemplate-list (map untemplate elems))))) + (splice untemplate ($tag ["lux" "Tuple"]) elems) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [(#Meta [_ unquoted]) #Nil])]))]) - (_meta unquoted) + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) + unquoted (#Meta [_ (#Form elems)]) - (wrap-meta (#Form (list (_meta (#Tag ["lux" "Form"])) (untemplate-list (map untemplate elems))))) + (splice untemplate ($tag ["lux" "Form"]) elems) (#Meta [_ (#Record fields)]) - (wrap-meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax))) - (lambda [kv] - (let [[k v] kv] - [k (untemplate v)]))) - fields))) + (wrap-meta (_meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax))) + (lambda [kv] + (let [[k v] kv] + [k (untemplate v)]))) + fields)))) )) -(defmacro (` tokens) +(defmacro #export (` tokens) (case' tokens (#Cons [template #Nil]) (return (:' SyntaxList @@ -651,9 +841,8 @@ _ (fail "Wrong syntax for `"))) -(export' `) -(defmacro (if tokens) +(defmacro #export (if tokens) (case' tokens (#Cons [test (#Cons [then (#Cons [else #Nil])])]) (return (:' SyntaxList @@ -663,14 +852,56 @@ _ (fail "Wrong syntax for if"))) -(export' if) -## (def (id x) -## (All [a] (-> a a)) -## x) -## (export' id) +## (deftype (Lux a) +## (-> CompilerState (Either Text (, CompilerState a)))) +(def #export Lux + Type + (All' [a] + (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' a))))))) -## (defmacro (^ tokens) +## (defsig (Monad m) +## (: (All [a] (-> a (m a))) +## return) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def' Monad + (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] + (case' ma + #None #None + (#Some a) (f a)))}) + +(def Lux:Monad + ($' Monad Lux) + {#lux;return + (lambda return [x] + (lambda [state] + (#Right [state x]))) + + #lux;bind + (lambda [f ma] + (lambda [state] + (case' (ma state) + (#Left msg) + (#Left msg) + + (#Right [state' a]) + (f a state'))))}) + +## (defmacro #export (^ tokens) ## (case' tokens ## (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) ## (return (:' SyntaxList @@ -678,14 +909,8 @@ ## _ ## (fail "Wrong syntax for ^"))) -## (export' ^) -## (defmacro (, tokens) -## (return (:' SyntaxList -## (list (` (#TupleT (list (~@ tokens)))))))) -## (export' ,) - -## (defmacro (-> tokens) +## (defmacro #export (-> tokens) ## (case' (reverse tokens) ## (#Cons [output inputs]) ## (return (:' SyntaxList @@ -697,946 +922,913 @@ ## _ ## (fail "Wrong syntax for ->"))) -## (export' ->) - -## (defmacro (| members) -## (let [members' (map (:' (->' Syntax Syntax) -## (lambda [m] -## (case' m -## (#Meta [_ (#Tag [module name])]) -## (` [(~ ($ text-++ module ";" name)) (#Tuple (list))]) - -## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))]) -## (` [(~ ($ text-++ module ";" name)) (~ value)])))) -## members)] -## (return (list (` (#VariantT (~ (untemplate-list members)))))))) -## (export' |) - -## (defmacro (& members) -## (let [members' (map (:' (->' Syntax Syntax) -## (lambda [m] -## (case' m -## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))]) -## (` [(~ ($ text-++ module ";" name)) (~ value)])))) -## members)] -## (return (list (` (#RecordT (~ (untemplate-list members)))))))) -## (export' &) - -## (def (text:= x y) -## (-> Text Text Bool) -## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] -## x [y])) - -## (def #export (int:+ x y) -## (-> Int Int Int) -## (jvm-ladd x y)) - -## (def (replace-ident ident value syntax) -## (-> (, Text Text) Syntax Syntax Syntax) -## (let [[module name] ident] -## (case' syntax -## (#Meta [_ (#Symbol [?module ?name])]) -## (if (and (text:= module ?module) -## (text:= name ?name)) -## value -## syntax) - -## (#Meta [_ (#Form members)]) -## (_meta (#Form (map (replace-ident ident value) members))) - -## (#Meta [_ (#Tuple members)]) -## (_meta (#Tuple (map (replace-ident ident value) members))) - -## (#Meta [_ (#Record members)]) -## (_meta (#Record (map (lambda [kv] -## (case' kv -## [k v] -## [k (replace-ident ident value v)])) -## members))) - -## _ -## syntax))) - -## (defmacro (All tokens) -## (let [[name args body] (case' tokens -## (#Cons [(#Meta [_ (#Symbol ["" name])]) (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])]) -## [name args body] - -## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) -## ["" args body]) -## rolled (fold (:' (-> Syntax Syntax Syntax) -## (lambda [body arg] -## (case' arg -## (#Meta [_ (#Symbol [arg-module arg-name])]) -## (` (#AllT #None "" (~ (_meta (#Text arg-name))) (~ (replace-ident [arg-module arg-name] -## (` (#BoundT (~ (#Text ($ text:++ arg-module ";" arg-name))))) -## body))))))) -## body -## args)] -## (case' rolled -## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ["lux" "AllT"])]) (#Cons [env (#Cons [(#Meta [_ (#Text "")]) (#Cons [(#Meta [_ (#Text arg-name)]) (#Cons [body #Nil])])])])]))]) -## (return (list (` (#AllT (~ env) (~ (#Text name)) (~ (#Text arg-name)) -## (~ (replace-ident arg-name (` (#BoundT (~ (#Text name)))) -## body))))))))) -## (export' All) - -## (defsig (Eq a) -## (: (-> a a Bool) -## =)) - -## (defstruct Text:Eq (Eq Text) -## (def = text=)) - -## (defstruct Ident:Eq (Eq Ident) -## (def (= x y) -## (let [[m1 n1] x -## [m2 n2] y] -## (and (text:= m1 m2) -## (text:= n1 n2))))) - -## (deftype (Dict k v) -## (: (-> k v (Dict k v) (Dict k v)) -## put) -## (: (-> k (Dict k v) (Maybe v)) -## get) -## (: (-> k (Dict k v) (Dict k v)) -## remove)) - -## (deftype (PList k v) -## (| (#PList (, (Eq k) (List (, k v)))))) - -## (def (some f xs) -## (All [a b] -## (-> (-> a (Maybe b)) (List a) (Maybe b))) -## (case' xs -## #Nil -## #None - -## (#Cons [x xs']) -## (if-let [y (f x)] -## (#Some y) -## (some f xs')) -## )) - -## (defstruct PList:Dict (Dict PList) -## (def (get k plist) -## (let [(#PList [{#= =} kvs]) plist] -## (some (:' (-> (, )) -## (lambda [kv] -## (let [[k' v'] kv] -## (when (= k k') -## v')))) -## kvs)))) - -## (deftype CompilerState -## (& #source (Maybe Reader) -## #modules (List Void) -## #module-aliases (List Void) -## #envs (List (Env Text Void)) -## #types (Bindings Int Type) -## #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #eval-ctor Int)) -## (deftype CompilerState -## (& (#source (Maybe Reader)) -## (#modules (PList Text Void)) -## (#module-aliases (PList Text Text)) -## (#envs (List (Env Text Void))) -## (#types (Bindings Int Type)) -## (#host (& (#writer (^ org.objectweb.asm.ClassWriter)) -## (#loader (^ java.net.URLClassLoader)) -## (#eval-ctor Int))))) -## (def (find-macro ident) -## (lambda [state] -## (let [[module name] ident] -## (case' state -## {#source source #modules modules #module-aliases module-aliases -## #envs envs #types types -## #writer writer #loader loader #eval-ctor eval-ctor} -## (when-let [bindings (get module modules) -## bound (get name bindings)] -## (case' bound -## (#Macro macro) -## (#Some macro) - -## _ -## #None)))))) - -## (def (walk-type type) -## (-> Syntax ($' Lux Syntax)) -## (case' type -## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol sym)]) args]))]) -## (do' [macro' (find-macro sym)] -## (case' macro' -## (#Some macro) -## (do' [expansion (macro args)] -## (case' expansion -## (#Cons [expansion' #Nil]) -## (walk-type expansion') - -## _ -## (fail "Macro can't expand to more than 1 output."))) - -## #None -## (do' [args' (map% walk-type args)] -## (return (fold (:' (-> Syntax Syntax Syntax) -## (lambda [f a] -## (` (#AppT [(~ f) (~ a)])))) -## sym -## args'))))) - -## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) args]))]) -## ... - -## (#Meta [_ (#Symbol _)]) -## (return type) - -## _ -## (fail "Wrong syntax for walk-type"))) - -## (defmacro (->type tokens) -## (case' tokens -## (#Cons [type #Nil]) -## (do' [type' (walk-type type)] -## (return (list type'))) - -## _ -## (fail "Wrong syntax for ->type"))) - -## (defmacro (: tokens) -## (case' tokens -## (#Cons [type (#Cons [value #Nil])]) -## (return (list (` (:' (->type (~ type)) (~ value))))) - -## _ -## (fail "Wrong syntax for :"))) - -## (defmacro (:! tokens) -## (case' tokens -## (#Cons [type (#Cons [value #Nil])]) -## (return (list (` (:!' (->type (~ type)) (~ value))))) - -## _ -## (fail "Wrong syntax for :!"))) - - - -## (def (print x) -## (-> (^ java.lang.Object) []) -## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] -## (jvm-getstatic java.lang.System "out") [x])) - -## (def (println x) -## (-> (^ java.lang.Object) []) -## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] -## (jvm-getstatic java.lang.System "out") [x])) - -## (deftype (IO a) -## (-> (,) a)) - -## (defmacro (io tokens) -## (case' tokens -## (#Cons [value #Nil]) -## (return (list (` (lambda [_] (~ value))))))) - -## (def (. f g) -## (All [a b c] -## (-> (-> b c) (-> a b) (-> a c))) -## (lambda [x] (f (g x)))) -## (def (++ xs ys) -## (All [a] -## (-> (List a) (List a) (List a))) -## (case' xs -## #Nil -## ys - -## (#Cons [x xs']) -## (#Cons [x (++ xs' ys)]))) - -## (def concat -## (All [a] -## (-> (List (List a)) (List a))) -## (fold ++ #Nil)) - -## (def flat-map -## (All [a b] -## (-> (-> a (List b)) (List a) (List b))) -## (. concat map)) - -## (def (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')))) +## (defmacro #export (, tokens) +## (return (:' SyntaxList +## (list (` (#TupleT (list (~@ tokens)))))))) -## (deftype (Lux a) -## (-> CompilerState (Either Text (, CompilerState a)))) +## (defmacro #export (| tokens) +## (do Lux:Monad +## [pairs (map% Lux:Monad +## (lambda [token] +## (case' token +## (#Tag ident) +## (;return (` [(~ ($text (ident->text ident))) (,)])) + +## (#Form (#Cons [(#Tag ident) (#Cons [value #Nil])])) +## (;return (` [(~ ($text (ident->text ident))) (~ value)])) + +## _ +## (fail "Wrong syntax for |"))) +## tokens)] +## (` (#VariantT (list (~@ pairs)))))) + +## (defmacro #export (& tokens) +## (if (not (int:= 2 (length tokens))) +## (fail "& expects an even number of arguments.") +## (do Lux:Monad +## [pairs (map% Lux:Monad +## (lambda [pair] +## (case' pair +## [(#Tag ident) value] +## (;return (` [(~ ($text (ident->text ident))) (~ value)])) + +## _ +## (fail "Wrong syntax for &"))) +## (as-pairs tokens))] +## (` (#RecordT (list (~@ pairs))))))) + +## (defmacro #export (All tokens) +## (case' (:' (, Ident SyntaxList) +## (case' tokens +## (#Cons [(#Meta [_ (#Symbol self-ident)]) tokens']) +## [self-ident tokens'] + +## _ +## [["" ""] tokens])) +## [self-ident tokens'] +## (case' tokens' +## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) +## (do Lux:Monad +## [idents (map% Lux:Monad get-ident args)] +## (case' idents +## #Nil +## (return (list body)) + +## (#Cons [harg targs]) +## (let [replacements (map (:' (-> Ident (, Ident Syntax)) +## (lambda [ident] +## (let [[module name] ident] +## [ident (_meta (#Bound ($ text:++ module ";" name)))]))) +## (list& self-ident idents)) +## body' (fold (lambda [body' arg'] +## (let [[module name] arg'] +## (` (#AllT [#None "" (~ ($text ($ text:++ module ";" name))) +## (~ body')])))) +## (replace-syntax replacements body) +## (reverse targs)) +## [smodule sname] self-ident +## [amodule aname] harg] +## (return (list (` (#AllT [#None (~ ($text ($ text:++ smodule ";" sname))) +## (~ ($text ($ text:++ amodule ";" aname))) +## (~ body')]))))))) + +## _ +## (fail "Wrong syntax for All")) +## )) -## (def (return val) -## (All [a] -## (-> a (Lux a))) -## (lambda [state] -## (#Right [state val]))) +## (def (ident->text ident) +## (->' Ident Text) +## (let [[module name] ident] +## ($ text:++ module ";" name))) + +## (def (map% monad f xs) +## (All' [m a b] +## (->' ($' Monad (B' m)) +## (->' (B' a) ($' (B' m) (B' b))) +## ($' (B' m) ($' List (B' b))))) +## (let [{#;return ;return #;bind ;bind} monad] +## (case' xs +## #Nil +## (;return #Nil) + +## (#Cons [x xs']) +## (do monad +## [x' (f x) +## xs'' (map% monad f xs')] +## (;return (#Cons [x' xs''])))))) -## (def (fail msg) -## (All [a] -## (-> Text (Lux a))) -## (lambda [_] -## (#Left msg))) - -## (def (bind f v) -## (All [m a b] (-> (-> a (m b)) (m a) (m b))) -## (lambda [state] -## (case' (v state) -## (#Right [state' x]) -## (f x state') - -## (#Left msg) -## (#Left msg)))) - -## (def (first pair) -## (All [a b] (-> (, a b) a)) -## (case' pair -## [f s] -## f)) - -## (def (second pair) -## (All [a b] (-> (, a b) b)) -## (case' pair -## [f s] -## s)) - -## (defmacro (loop tokens) -## (case' tokens -## (#Cons [bindings (#Cons [body #Nil])]) -## (let [pairs (as-pairs bindings)] -## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["lux" "recur"])) (~ (#Tuple (map first pairs))) -## (~ body))) -## (map second pairs)]))))))) - -## (defmacro (export tokens) -## (return (map (lambda [t] (` (export' (~ t)))) -## tokens))) - -## (defmacro (and tokens) -## (let [as-if (case' tokens -## #Nil -## (` true) - -## (#Cons [init tests]) -## (fold (lambda [prev next] -## (` (if (~ prev) (~ next) false))) -## init -## tokens) -## )] -## (return (list as-if)))) - -## (defmacro (or tokens) -## (let [as-if (case' tokens -## #Nil -## (` false) - -## (#Cons [init tests]) -## (fold (lambda [prev next] -## (` (if (~ prev) true (~ next)))) -## init -## tokens) -## )] -## (return (list as-if)))) - -## (def (not x) -## (-> Bool Bool) -## (case' x -## true false -## false true)) - -## (defmacro (|> tokens) -## (case' tokens -## (#Cons [init apps]) -## (return (list (fold (lambda [acc app] -## (case' app -## (#Form parts) -## (#Form (++ parts (list acc))) - -## _ -## (` ((~ app) (~ acc))))) -## init -## apps))))) - -## (defmacro ($ tokens) +## (defmacro (do tokens) ## (case' tokens -## (#Cons [op (#Cons [init args])]) -## (return (list (fold (lambda [acc elem] -## (` ((~ op) (~ acc) (~ elem)))) -## init -## args))))) - -## (def (const x) -## (All [a b] -## (-> a (-> b a))) -## (lambda [_] -## x)) - -## (def (int> x y) -## (-> Int Int Bool) -## (jvm-lgt x y)) - -## (def (int< x y) -## (-> Int Int Bool) -## (jvm-llt x y)) - -## (def inc -## (-> Int Int) -## (int+ 1)) - -## (def dec -## (-> Int Int) -## (int+ -1)) - -## (def (repeat n x) -## (All [a] (-> Int a (List a))) -## (if (int> n 0) -## (#Cons [x (repeat (dec n) x)]) -## #Nil)) - -## (def size -## (All [a] -## (-> (List a) Int)) -## (fold (lambda [acc _] (inc acc)) 0)) - -## (def (last xs) -## (All [a] -## (-> (List a) (Maybe a))) -## (case' xs -## #Nil #None -## (#Cons [x #Nil]) (#Some x) -## (#Cons [_ xs']) (last xs'))) - -## (def (init xs) -## (All [a] -## (-> (List a) (Maybe (List a)))) -## (case' xs -## #Nil #None -## (#Cons [_ #Nil]) (#Some #Nil) -## (#Cons [x xs']) (case' (init xs') -## (#Some xs'') -## (#Some (#Cons [x xs''])) - -## _ -## (#Some (#Cons [x #Nil]))))) - -## (defmacro (cond tokens) -## (case' (reverse tokens) -## (#Cons [else branches']) -## (return (list (fold (lambda [else branch] -## (case' branch -## [test then] -## (` (if (~ test) (~ then) (~ else))))) -## else -## (|> branches' reverse as-pairs)))))) - -## (def (interleave xs ys) -## (All [a] -## (-> (List a) (List a) (List a))) -## (case' [xs ys] -## [(#Cons [x xs']) (#Cons [y ys'])] -## (list+ x y (interleave xs' ys')) - -## _ -## #Nil)) - -## (def (interpose sep xs) -## (All [a] -## (-> a (List a) (List a))) -## (case' xs -## #Nil -## xs - -## (#Cons [x #Nil]) -## xs - -## (#Cons [x xs']) -## (list+ x sep (interpose sep xs')))) - -## (def (empty? xs) -## (All [a] -## (-> (List a) Bool)) -## (case' xs -## #Nil true -## _ false)) - -## ## (do-template [<name> <op>] -## ## (def (<name> p xs) -## ## (case xs -## ## #Nil true -## ## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) - -## ## [every? and] -## ## [any? or]) - -## (deftype Ordering -## (| #< #> #=)) - -## (defsig (Ord a) -## (: (-> a a Ordering) -## compare)) - -## (defsig (Enum a) -## (: (Ord a) -## order) - -## (: (-> a a) -## succ) - -## (: (-> a a) -## pred)) - -## (def (range enum from to) -## (All [a] -## (-> (Enum a) a a (List a))) -## (using [enum order] -## (case' (compare from to) -## #< -## (list& from (range enum (succ from) to)) - -## _ -## #Nil))) - -## (def (range from to) -## (-> Int Int (List Int)) -## (if (int< from to) -## (#Cons [from (range (inc from) to)]) -## #Nil)) - -## (def (tuple->list tuple) -## (-> Syntax (List Syntax)) -## (case' tuple -## (#Meta [_ (#Tuple list)]) -## list)) - -## (def (zip2 xs ys) -## (All [a b] -## (-> (List a) (List b) (List (, a b)))) -## (case' [xs ys] -## [(#Cons [x xs']) (#Cons [y ys'])] -## (#Cons [[x y] (zip2 xs' ys')]) +## (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) +## (return (:' SyntaxList +## (list (` (case' (~ monad) +## {#;return ;return #;bind ;bind} +## (~ (fold (:' (-> Syntax (, Syntax Syntax) Syntax) +## (lambda [body' binding] +## (let [[lhs rhs] binding] +## (` (;bind (lambda [(~ lhs)] (~ body')) (~ rhs)))))) +## body +## (reverse (as-pairs bindings))))))))) ## _ -## #Nil)) - -## (def (get-ident x) -## (-> Syntax Text) -## (case' x -## (#Meta [_ (#Symbol [_ ident])]) -## ident)) - -## (def (text-++ x y) -## (-> Text Text Text) -## (jvm-invokevirtual java.lang.String "concat" [java.lang.String] -## x [y])) - -## (def (show-env env) -## ... -## (|> env (map first) (interpose ", ") (fold text-++ ""))) - -## (def (apply-template env template) -## (case' template -## (#Meta [_ (#Symbol [_ ident])]) -## (case' (get ident env) -## (#Some subst) -## subst - -## _ -## template) - -## (#Meta [_ (#Tuple elems)]) -## (_meta (#Tuple (map (apply-template env) elems))) +## (fail "Wrong syntax for do"))) -## (#Meta [_ (#Form elems)]) -## (_meta (#Form (map (apply-template env) elems))) - -## (#Meta [_ (#Record members)]) -## (_meta (#Record (map (lambda [kv] -## (case' kv -## [slot value] -## [(apply-template env slot) (apply-template env value)])) -## members))) +## (def #export (find-macro ident state) +## (->' Ident ($' Lux Macro)) +## (let [[module name] ident] +## (case' state +## {#source source #modules modules #module-aliases module-aliases +## #envs envs #types types #host host} +## (case' (:' ($' Maybe Macro) +## (do Maybe:Monad +## [bindings (get module modules) +## gdef (get name bindings)] +## (case' gdef +## (#MacroD macro') +## macro' + +## _ +## #None))) +## (#Some macro) +## (#Right [state macro]) + +## #None +## (#Left ($ text:++ "There is no macro by the name: " module ";" name)))))) + +## ## (def (id x) +## ## (All [a] (-> a a)) +## ## x) +## ## (export' id) + +## ## (def (text:= x y) +## ## (-> Text Text Bool) +## ## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] +## ## x [y])) + +## ## (def #export (int:+ x y) +## ## (-> Int Int Int) +## ## (jvm-ladd x y)) + +## ## (def (replace-ident ident value syntax) +## ## (-> (, Text Text) Syntax Syntax Syntax) +## ## (let [[module name] ident] +## ## (case' syntax +## ## (#Meta [_ (#Symbol [?module ?name])]) +## ## (if (and (text:= module ?module) +## ## (text:= name ?name)) +## ## value +## ## syntax) + +## ## (#Meta [_ (#Form members)]) +## ## (_meta (#Form (map (replace-ident ident value) members))) + +## ## (#Meta [_ (#Tuple members)]) +## ## (_meta (#Tuple (map (replace-ident ident value) members))) + +## ## (#Meta [_ (#Record members)]) +## ## (_meta (#Record (map (lambda [kv] +## ## (case' kv +## ## [k v] +## ## [k (replace-ident ident value v)])) +## ## members))) + +## ## _ +## ## syntax))) + +## ## (defsig (Eq a) +## ## (: (-> a a Bool) +## ## =)) + +## ## (defstruct Text:Eq (Eq Text) +## ## (def = text=)) + +## ## (defstruct Ident:Eq (Eq Ident) +## ## (def (= x y) +## ## (let [[m1 n1] x +## ## [m2 n2] y] +## ## (and (text:= m1 m2) +## ## (text:= n1 n2))))) + +## ## (deftype (Dict k v) +## ## (: (-> k v (Dict k v) (Dict k v)) +## ## put) +## ## (: (-> k (Dict k v) (Maybe v)) +## ## get) +## ## (: (-> k (Dict k v) (Dict k v)) +## ## remove)) + +## ## (deftype (PList k v) +## ## (| (#PList (, (Eq k) (List (, k v)))))) + +## ## (def (some f xs) +## ## (All [a b] +## ## (-> (-> a (Maybe b)) (List a) (Maybe b))) +## ## (case' xs +## ## #Nil +## ## #None + +## ## (#Cons [x xs']) +## ## (if-let [y (f x)] +## ## (#Some y) +## ## (some f xs')) +## ## )) + +## ## (defstruct PList:Dict (Dict PList) +## ## (def (get k plist) +## ## (let [(#PList [{#= =} kvs]) plist] +## ## (some (:' (-> (, )) +## ## (lambda [kv] +## ## (let [[k' v'] kv] +## ## (when (= k k') +## ## v')))) +## ## kvs)))) + +## ## (def (walk-type type) +## ## (-> Syntax ($' Lux Syntax)) +## ## (case' type +## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol sym)]) args]))]) +## ## (do' [macro' (find-macro sym)] +## ## (case' macro' +## ## (#Some macro) +## ## (do' [expansion (macro args)] +## ## (case' expansion +## ## (#Cons [expansion' #Nil]) +## ## (walk-type expansion') + +## ## _ +## ## (fail "Macro can't expand to more than 1 output."))) + +## ## #None +## ## (do' [args' (map% walk-type args)] +## ## (return (fold (:' (-> Syntax Syntax Syntax) +## ## (lambda [f a] +## ## (` (#AppT [(~ f) (~ a)])))) +## ## sym +## ## args'))))) + +## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) args]))]) +## ## ... + +## ## (#Meta [_ (#Symbol _)]) +## ## (return type) + +## ## _ +## ## (fail "Wrong syntax for walk-type"))) + +## ## (defmacro (->type tokens) +## ## (case' tokens +## ## (#Cons [type #Nil]) +## ## (do' [type' (walk-type type)] +## ## (return (list type'))) -## _ -## template)) +## ## _ +## ## (fail "Wrong syntax for ->type"))) -## (defmacro (do-templates tokens) -## (case' tokens -## (#Cons [bindings (#Cons [(#Meta [_ (#Tuple templates)]) data])]) -## (let [bindings-list (map get-ident (tuple->list bindings)) -## data-lists (map tuple->list data) -## apply (lambda [env] (map (apply-template env) templates))] -## (|> data-lists -## (map (. apply (zip2 bindings-list))) -## return)))) - -## ## (do-template [<name> <offset>] -## ## (def <name> (int+ <offset>)) - -## ## [inc 1] -## ## [dec -1]) - -## (def (int= x y) -## (-> Int Int Bool) -## (jvm-leq x y)) - -## (def (int% x y) -## (-> Int Int Int) -## (jvm-lrem x y)) - -## (def (int>= x y) -## (-> Int Int Bool) -## (or (int= x y) -## (int> x y))) - -## (do-templates [<name> <cmp>] -## [(def (<name> x y) -## (-> Int Int Int) -## (if (<cmp> x y) -## x -## y))] - -## [max int>] -## [min int<]) - -## (do-templates [<name> <cmp>] -## [(def (<name> n) -## (-> Int Bool) -## (<cmp> n 0))] - -## [neg? int<] -## [pos? int>=]) - -## (def (even? n) -## (-> Int Bool) -## (int= 0 (int% n 0))) - -## (def (odd? n) -## (-> Int Bool) -## (not (even? n))) - -## (do-templates [<name> <done> <step>] -## [(def (<name> n xs) -## (All [a] -## (-> Int (List a) (List a))) -## (if (int> n 0) -## (case' xs -## #Nil #Nil -## (#Cons [x xs']) <step>) -## <done>))] - -## [take #Nil (list+ x (take (dec n) xs'))] -## [drop xs (drop (dec n) xs')]) - -## (do-templates [<name> <done> <step>] -## [(def (<name> f xs) -## (All [a] -## (-> (-> a Bool) (List a) (List a))) -## (case' xs -## #Nil #Nil -## (#Cons [x xs']) (if (f x) <step> #Nil)))] - -## [take-while #Nil (list+ x (take-while f xs'))] -## [drop-while xs (drop-while f xs')]) - -## ## (defmacro (get@ tokens) -## ## (let [output (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 (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 (case' tokens -## ## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) -## ## (` (let [_record_ (~ record)] -## ## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) - -## ## (#Cons [tag (#Cons [func #Nil])]) -## ## (` (lambda [record] -## ## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) - -## ## (#Cons [tag #Nil]) -## ## (` (lambda [func record] -## ## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] -## ## (return (list output)))) - -## (def (show-int int) -## (-> Int Text) -## (jvm-invokevirtual java.lang.Object "toString" [] -## int [])) - -## (def gensym -## (LuxStateM Syntax) -## (lambda [state] -## [(update@ [#gen-seed] inc state) -## (_meta (#Symbol ($ text-++ "__" (show-int (get@ [#gen-seed] state)) "__")))])) - -## ## (do-template [<name> <member>] -## ## (def (<name> pair) -## ## (case' pair -## ## [f s] -## ## <member>)) - -## ## [first f] -## ## [second s]) - -## (def (show-syntax syntax) -## (-> Syntax Text) -## (case' syntax -## (#Meta [_ (#Bool value)]) -## (jvm-invokevirtual java.lang.Object "toString" [] -## value []) +## ## (defmacro (: tokens) +## ## (case' tokens +## ## (#Cons [type (#Cons [value #Nil])]) +## ## (return (list (` (:' (->type (~ type)) (~ value))))) -## (#Meta [_ (#Int value)]) -## (jvm-invokevirtual java.lang.Object "toString" [] -## value []) +## ## _ +## ## (fail "Wrong syntax for :"))) -## (#Meta [_ (#Real value)]) -## (jvm-invokevirtual java.lang.Object "toString" [] -## value []) +## ## (defmacro (:! tokens) +## ## (case' tokens +## ## (#Cons [type (#Cons [value #Nil])]) +## ## (return (list (` (:!' (->type (~ type)) (~ value))))) -## (#Meta [_ (#Char value)]) -## (jvm-invokevirtual java.lang.Object "toString" [] -## value []) +## ## _ +## ## (fail "Wrong syntax for :!"))) -## (#Meta [_ (#Text value)]) -## (jvm-invokevirtual java.lang.Object "toString" [] -## value []) -## (#Meta [_ (#Symbol [module name])]) -## ($ text-++ module ";" name) -## (#Meta [_ (#Tag [module name])]) -## ($ text-++ "#" module ";" name) +## ## (def (print x) +## ## (-> (^ java.lang.Object) []) +## ## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] +## ## (jvm-getstatic java.lang.System "out") [x])) -## (#Meta [_ (#Tuple members)]) -## ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]") +## ## (def (println x) +## ## (-> (^ java.lang.Object) []) +## ## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] +## ## (jvm-getstatic java.lang.System "out") [x])) -## (#Meta [_ (#Form members)]) -## ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")") -## )) +## ## (deftype (IO a) +## ## (-> (,) a)) -## (defmacro (do tokens) -## (case' tokens -## (#Cons [(#Meta [_ monad]) (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) -## (let [output (fold (lambda [body binding] -## (case' binding -## [lhs rhs] -## (` (lux;bind (lambda [(~ lhs)] (~ body)) -## (~ rhs))))) -## body -## (reverse (as-pairs bindings)))] -## (return (list (` (using (~ monad) (~ output)))))))) - -## (def (map% f xs) -## (All [m a b] -## (-> (-> a (m b)) (List a) (m (List b)))) -## (case' xs -## #Nil -## (return xs) - -## (#Cons [x xs']) -## (do [y (f x) -## ys (map% f xs')] -## (return (#Cons [y ys]))))) - -## ## (defmacro ($keys tokens) +## ## (defmacro (io tokens) ## ## (case' tokens -## ## (#Cons [(#Meta [_ (#Tuple fields)]) #Nil]) -## ## (return (list (_meta (#Record (map (lambda [slot] -## ## (case' slot -## ## (#Meta [_ (#Tag [module name])]) -## ## [($ text-++ module ";" name) (_meta (#Symbol [module name]))])) -## ## fields))))))) - -## ## (defmacro ($or tokens) +## ## (#Cons [value #Nil]) +## ## (return (list (` (lambda [_] (~ value))))))) + +## ## (def (. f g) +## ## (All [a b c] +## ## (-> (-> b c) (-> a b) (-> a c))) +## ## (lambda [x] +## ## (f (g x)))) + +## ## (def (++ xs ys) +## ## (All [a] +## ## (-> (List a) (List a) (List a))) +## ## (case' xs +## ## #Nil +## ## ys + +## ## (#Cons [x xs']) +## ## (#Cons [x (++ xs' ys)]))) + +## ## (def concat +## ## (All [a] +## ## (-> (List (List a)) (List a))) +## ## (fold ++ #Nil)) + +## ## (def flat-map +## ## (All [a b] +## ## (-> (-> a (List b)) (List a) (List b))) +## ## (. concat map)) + +## ## (def (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')))) + +## ## (deftype (Lux a) +## ## (-> CompilerState (Either Text (, CompilerState a)))) + +## ## (def (first pair) +## ## (All [a b] (-> (, a b) a)) +## ## (case' pair +## ## [f s] +## ## f)) + +## ## (def (second pair) +## ## (All [a b] (-> (, a b) b)) +## ## (case' pair +## ## [f s] +## ## s)) + +## ## (defmacro (loop tokens) ## ## (case' tokens -## ## (#Cons [(#Meta [_ (#Tuple patterns)]) (#Cons [body #Nil])]) -## ## (return (flat-map (lambda [pattern] (list pattern body)) -## ## patterns)))) - -## (def (macro-expand syntax) -## (-> Syntax (LuxStateM (List Syntax))) -## (case' syntax -## (#Form (#Cons [(#Symbol macro-name) args])) -## (do [macro (get-macro macro-name)] -## ((:'! macro Macro) args)))) - -## (defmacro (case tokens) -## (case' tokens -## (#Cons value branches) -## (loop [kind #Pattern -## pieces branches -## new-pieces (list)] -## (case' pieces -## #Nil -## (return (list (' (case' (~ value) (~@ new-pieces))))) - -## (#Cons piece pieces') -## (let [[kind' expanded more-pieces] (case' kind -## #Body -## [#Pattern (list piece) #Nil] - -## #Pattern -## (do [expansion (macro-expand piece)] -## (case' expansion -## #Nil -## [#Pattern #Nil #Nil] - -## (#Cons exp #Nil) -## [#Body (list exp) #Nil] - -## (#Cons exp exps) -## [#Body (list exp) exps])) -## )] -## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) -## ))) - -## (def (defsyntax tokens) -## ...) - -## (deftype (State s a) -## (-> s (, s a))) - -## (deftype (Parser a) -## (State (List Syntax) a)) - -## (def (parse-ctor tokens) -## (Parser (, Syntax (List Syntax))) -## (case tokens -## (list+ (#Symbol name) tokens') -## [tokens' [(#Symbol name) (list)]] - -## (list+ (#Form (list+ (#Symbol name) args)) tokens') -## [tokens' [(#Symbol name) args]])) - -## (defsyntax (defsig -## [[name args] parse-ctor] -## [anns ($+ $1)]) -## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) -## (` (#Record (~ (untemplate-list ...)))) -## args)] -## (return (list (` (def (~ name) (~ def-body))))))) - -## (defsyntax (defstruct -## [[name args] parse-ctor] -## signature -## [defs ($+ $1)]) -## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) -## (` (#Record (~ (untemplate-list ...)))) -## args)] -## (return (list (` (def (~ name) -## (:' (~ def-body) (~ signature)))))))) - -## (defsig (Monad m) -## (:' (All [a] (-> a (m a))) -## return) -## (:' (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) - -## (defstruct ListMonad (Monad List) -## (def (return x) -## (list x)) - -## (def bind (. concat map))) - -## (defsig (Eq a) -## (:' = (-> a a Bool))) - -## (defstruct (List_Eq A_Eq) -## (All [a] (-> (Eq a) (Eq (List a)))) - -## (def (= xs ys) -## (and (= (length xs) (length ys)) -## (map (lambda [[x y]] -## (with A_Eq -## (= x y))) -## (zip2 xs ys))))) - -## ## (def (with tokens) +## ## (#Cons [bindings (#Cons [body #Nil])]) +## ## (let [pairs (as-pairs bindings)] +## ## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["lux" "recur"])) (~ (#Tuple (map first pairs))) +## ## (~ body))) +## ## (map second pairs)]))))))) + +## ## (defmacro (and tokens) +## ## (let [as-if (case' tokens +## ## #Nil +## ## (` true) + +## ## (#Cons [init tests]) +## ## (fold (lambda [prev next] +## ## (` (if (~ prev) (~ next) false))) +## ## init +## ## tokens) +## ## )] +## ## (return (list as-if)))) + +## ## (defmacro (or tokens) +## ## (let [as-if (case' tokens +## ## #Nil +## ## (` false) + +## ## (#Cons [init tests]) +## ## (fold (lambda [prev next] +## ## (` (if (~ prev) true (~ next)))) +## ## init +## ## tokens) +## ## )] +## ## (return (list as-if)))) + +## ## (def (not x) +## ## (-> Bool Bool) +## ## (case' x +## ## true false +## ## false true)) + +## ## (defmacro (|> tokens) +## ## (case' tokens +## ## (#Cons [init apps]) +## ## (return (list (fold (lambda [acc app] +## ## (case' app +## ## (#Form parts) +## ## (#Form (++ parts (list acc))) + +## ## _ +## ## (` ((~ app) (~ acc))))) +## ## init +## ## apps))))) + +## ## (defmacro ($ tokens) +## ## (case' tokens +## ## (#Cons [op (#Cons [init args])]) +## ## (return (list (fold (lambda [acc elem] +## ## (` ((~ op) (~ acc) (~ elem)))) +## ## init +## ## args))))) + +## ## (def (const x) +## ## (All [a b] +## ## (-> a (-> b a))) +## ## (lambda [_] +## ## x)) + +## ## (def (int> x y) +## ## (-> Int Int Bool) +## ## (jvm-lgt x y)) + +## ## (def (int< x y) +## ## (-> Int Int Bool) +## ## (jvm-llt x y)) + +## ## (def inc +## ## (-> Int Int) +## ## (int+ 1)) + +## ## (def dec +## ## (-> Int Int) +## ## (int+ -1)) + +## ## (def (repeat n x) +## ## (All [a] (-> Int a (List a))) +## ## (if (int> n 0) +## ## (#Cons [x (repeat (dec n) x)]) +## ## #Nil)) + +## ## (def size +## ## (All [a] +## ## (-> (List a) Int)) +## ## (fold (lambda [acc _] (inc acc)) 0)) + +## ## (def (last xs) +## ## (All [a] +## ## (-> (List a) (Maybe a))) +## ## (case' xs +## ## #Nil #None +## ## (#Cons [x #Nil]) (#Some x) +## ## (#Cons [_ xs']) (last xs'))) + +## ## (def (init xs) +## ## (All [a] +## ## (-> (List a) (Maybe (List a)))) +## ## (case' xs +## ## #Nil #None +## ## (#Cons [_ #Nil]) (#Some #Nil) +## ## (#Cons [x xs']) (case' (init xs') +## ## (#Some xs'') +## ## (#Some (#Cons [x xs''])) + +## ## _ +## ## (#Some (#Cons [x #Nil]))))) + +## ## (defmacro (cond tokens) +## ## (case' (reverse tokens) +## ## (#Cons [else branches']) +## ## (return (list (fold (lambda [else branch] +## ## (case' branch +## ## [test then] +## ## (` (if (~ test) (~ then) (~ else))))) +## ## else +## ## (|> branches' reverse as-pairs)))))) + +## ## (def (interleave xs ys) +## ## (All [a] +## ## (-> (List a) (List a) (List a))) +## ## (case' [xs ys] +## ## [(#Cons [x xs']) (#Cons [y ys'])] +## ## (list+ x y (interleave xs' ys')) + +## ## _ +## ## #Nil)) + +## ## (def (interpose sep xs) +## ## (All [a] +## ## (-> a (List a) (List a))) +## ## (case' xs +## ## #Nil +## ## xs + +## ## (#Cons [x #Nil]) +## ## xs + +## ## (#Cons [x xs']) +## ## (list+ x sep (interpose sep xs')))) + +## ## (def (empty? xs) +## ## (All [a] +## ## (-> (List a) Bool)) +## ## (case' xs +## ## #Nil true +## ## _ false)) + +## ## ## (do-template [<name> <op>] +## ## ## (def (<name> p xs) +## ## ## (case xs +## ## ## #Nil true +## ## ## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) + +## ## ## [every? and] +## ## ## [any? or]) + +## ## (def (tuple->list tuple) +## ## (-> Syntax (List Syntax)) +## ## (case' tuple +## ## (#Meta [_ (#Tuple list)]) +## ## list)) + +## ## (def (zip2 xs ys) +## ## (All [a b] +## ## (-> (List a) (List b) (List (, a b)))) +## ## (case' [xs ys] +## ## [(#Cons [x xs']) (#Cons [y ys'])] +## ## (#Cons [[x y] (zip2 xs' ys')]) + +## ## _ +## ## #Nil)) + +## ## (def (get-ident x) +## ## (-> Syntax Text) +## ## (case' x +## ## (#Meta [_ (#Symbol [_ ident])]) +## ## ident)) + +## ## (def (text-++ x y) +## ## (-> Text Text Text) +## ## (jvm-invokevirtual java.lang.String "concat" [java.lang.String] +## ## x [y])) + +## ## (def (show-env env) +## ## ... +## ## (|> env (map first) (interpose ", ") (fold text-++ ""))) + +## ## (def (apply-template env template) +## ## (case' template +## ## (#Meta [_ (#Symbol [_ ident])]) +## ## (case' (get ident env) +## ## (#Some subst) +## ## subst + +## ## _ +## ## template) + +## ## (#Meta [_ (#Tuple elems)]) +## ## (_meta (#Tuple (map (apply-template env) elems))) + +## ## (#Meta [_ (#Form elems)]) +## ## (_meta (#Form (map (apply-template env) elems))) + +## ## (#Meta [_ (#Record members)]) +## ## (_meta (#Record (map (lambda [kv] +## ## (case' kv +## ## [slot value] +## ## [(apply-template env slot) (apply-template env value)])) +## ## members))) + +## ## _ +## ## template)) + +## ## (defmacro (do-templates tokens) +## ## (case' tokens +## ## (#Cons [bindings (#Cons [(#Meta [_ (#Tuple templates)]) data])]) +## ## (let [bindings-list (map get-ident (tuple->list bindings)) +## ## data-lists (map tuple->list data) +## ## apply (lambda [env] (map (apply-template env) templates))] +## ## (|> data-lists +## ## (map (. apply (zip2 bindings-list))) +## ## return)))) + +## ## ## (do-template [<name> <offset>] +## ## ## (def <name> (int+ <offset>)) + +## ## ## [inc 1] +## ## ## [dec -1]) + +## ## (def (int= x y) +## ## (-> Int Int Bool) +## ## (jvm-leq x y)) + +## ## (def (int% x y) +## ## (-> Int Int Int) +## ## (jvm-lrem x y)) + +## ## (def (int>= x y) +## ## (-> Int Int Bool) +## ## (or (int= x y) +## ## (int> x y))) + +## ## (do-templates [<name> <cmp>] +## ## [(def (<name> x y) +## ## (-> Int Int Int) +## ## (if (<cmp> x y) +## ## x +## ## y))] + +## ## [max int>] +## ## [min int<]) + +## ## (do-templates [<name> <cmp>] +## ## [(def (<name> n) +## ## (-> Int Bool) +## ## (<cmp> n 0))] + +## ## [neg? int<] +## ## [pos? int>=]) + +## ## (def (even? n) +## ## (-> Int Bool) +## ## (int= 0 (int% n 0))) + +## ## (def (odd? n) +## ## (-> Int Bool) +## ## (not (even? n))) + +## ## (do-templates [<name> <done> <step>] +## ## [(def (<name> n xs) +## ## (All [a] +## ## (-> Int (List a) (List a))) +## ## (if (int> n 0) +## ## (case' xs +## ## #Nil #Nil +## ## (#Cons [x xs']) <step>) +## ## <done>))] + +## ## [take #Nil (list+ x (take (dec n) xs'))] +## ## [drop xs (drop (dec n) xs')]) + +## ## (do-templates [<name> <done> <step>] +## ## [(def (<name> f xs) +## ## (All [a] +## ## (-> (-> a Bool) (List a) (List a))) +## ## (case' xs +## ## #Nil #Nil +## ## (#Cons [x xs']) (if (f x) <step> #Nil)))] + +## ## [take-while #Nil (list+ x (take-while f xs'))] +## ## [drop-while xs (drop-while f xs')]) + +## ## ## (defmacro (get@ tokens) +## ## ## (let [output (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 (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 (case' tokens +## ## ## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) +## ## ## (` (let [_record_ (~ record)] +## ## ## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) + +## ## ## (#Cons [tag (#Cons [func #Nil])]) +## ## ## (` (lambda [record] +## ## ## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) + +## ## ## (#Cons [tag #Nil]) +## ## ## (` (lambda [func record] +## ## ## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] +## ## ## (return (list output)))) + +## ## (def (show-int int) +## ## (-> Int Text) +## ## (jvm-invokevirtual java.lang.Object "toString" [] +## ## int [])) + +## ## (def gensym +## ## (LuxStateM Syntax) +## ## (lambda [state] +## ## [(update@ [#gen-seed] inc state) +## ## (_meta (#Symbol ($ text-++ "__" (show-int (get@ [#gen-seed] state)) "__")))])) + +## ## ## (do-template [<name> <member>] +## ## ## (def (<name> pair) +## ## ## (case' pair +## ## ## [f s] +## ## ## <member>)) + +## ## ## [first f] +## ## ## [second s]) + +## ## (def (show-syntax syntax) +## ## (-> Syntax Text) +## ## (case' syntax +## ## (#Meta [_ (#Bool value)]) +## ## (jvm-invokevirtual java.lang.Object "toString" [] +## ## value []) + +## ## (#Meta [_ (#Int value)]) +## ## (jvm-invokevirtual java.lang.Object "toString" [] +## ## value []) + +## ## (#Meta [_ (#Real value)]) +## ## (jvm-invokevirtual java.lang.Object "toString" [] +## ## value []) + +## ## (#Meta [_ (#Char value)]) +## ## (jvm-invokevirtual java.lang.Object "toString" [] +## ## value []) + +## ## (#Meta [_ (#Text value)]) +## ## (jvm-invokevirtual java.lang.Object "toString" [] +## ## value []) + +## ## (#Meta [_ (#Symbol [module name])]) +## ## ($ text-++ module ";" name) + +## ## (#Meta [_ (#Tag [module name])]) +## ## ($ text-++ "#" module ";" name) + +## ## (#Meta [_ (#Tuple members)]) +## ## ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]") + +## ## (#Meta [_ (#Form members)]) +## ## ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")") +## ## )) + +## ## (defmacro (do tokens) +## ## (case' tokens +## ## (#Cons [(#Meta [_ monad]) (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) +## ## (let [output (fold (lambda [body binding] +## ## (case' binding +## ## [lhs rhs] +## ## (` (lux;bind (lambda [(~ lhs)] (~ body)) +## ## (~ rhs))))) +## ## body +## ## (reverse (as-pairs bindings)))] +## ## (return (list (` (using (~ monad) (~ output)))))))) + +## ## (def (map% f xs) +## ## (All [m a b] +## ## (-> (-> a (m b)) (List a) (m (List b)))) +## ## (case' xs +## ## #Nil +## ## (return xs) + +## ## (#Cons [x xs']) +## ## (do [y (f x) +## ## ys (map% f xs')] +## ## (return (#Cons [y ys]))))) + +## ## ## (defmacro ($keys tokens) +## ## ## (case' tokens +## ## ## (#Cons [(#Meta [_ (#Tuple fields)]) #Nil]) +## ## ## (return (list (_meta (#Record (map (lambda [slot] +## ## ## (case' slot +## ## ## (#Meta [_ (#Tag [module name])]) +## ## ## [($ text-++ module ";" name) (_meta (#Symbol [module name]))])) +## ## ## fields))))))) + +## ## ## (defmacro ($or tokens) +## ## ## (case' tokens +## ## ## (#Cons [(#Meta [_ (#Tuple patterns)]) (#Cons [body #Nil])]) +## ## ## (return (flat-map (lambda [pattern] (list pattern body)) +## ## ## patterns)))) + +## ## (def (macro-expand syntax) +## ## (-> Syntax (LuxStateM (List Syntax))) +## ## (case' syntax +## ## (#Form (#Cons [(#Symbol macro-name) args])) +## ## (do [macro (get-macro macro-name)] +## ## ((:'! macro Macro) args)))) + +## ## (defmacro (case tokens) +## ## (case' tokens +## ## (#Cons value branches) +## ## (loop [kind #Pattern +## ## pieces branches +## ## new-pieces (list)] +## ## (case' pieces +## ## #Nil +## ## (return (list (' (case' (~ value) (~@ new-pieces))))) + +## ## (#Cons piece pieces') +## ## (let [[kind' expanded more-pieces] (case' kind +## ## #Body +## ## [#Pattern (list piece) #Nil] + +## ## #Pattern +## ## (do [expansion (macro-expand piece)] +## ## (case' expansion +## ## #Nil +## ## [#Pattern #Nil #Nil] + +## ## (#Cons exp #Nil) +## ## [#Body (list exp) #Nil] + +## ## (#Cons exp exps) +## ## [#Body (list exp) exps])) +## ## )] +## ## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) +## ## ))) + +## ## (def (defsyntax tokens) ## ## ...) -## ## (import "lux") -## ## (module-alias "lux" "l") -## ## (def-alias "lux;map" "map") +## ## (deftype (State s a) +## ## (-> s (, s a))) + +## ## (deftype (Parser a) +## ## (State (List Syntax) a)) -## ## (def (require tokens) +## ## (def (parse-ctor tokens) +## ## (Parser (, Syntax (List Syntax))) ## ## (case tokens -## ## ...)) - -## ## (require lux #as l #refer [map]) - -## (defsyntax #export (All [name (%? %name)] [args %args] body) -## (let [name' (case name -## #None "" -## (#Some name) name) -## arg-replacements (map (lambda [arg] -## [(#Symbol ["" arg]) (` (#Bound (~ arg)))]) -## args) -## args' (map (lambda [arg] -## (#Symbol ["" arg])) -## args) -## body' (replace-syntax arg-replacements body)] -## (return (list (` (#AllT [#None (~ name') (#Tuple (list (~@ args'))) -## (~ body')])))))) - -## (def (walk-syntax type) -## (case type -## (#Meta [_ (#Form (\list& op args))]) -## (case op -## (#Meta [_ (#Symbol ident)]) -## (do' [macro?? (find-macro ident)] -## (case macro?? -## (#Some macro) -## (do' [expansion (macro args)] -## (flat-map% walk-syntax expansion)) - -## #None -## (do' [flat-map% (map% walk-syntax args)] -## (return (list (fold (lambda [fun arg] -## (` (#AppT [(~ fun) (~ arg)]))) -## op -## args)))))) - -## _ -## (do' [flat-map% (map% walk-syntax args)] -## (return (list (_meta (#Form (list op args'))))))) - -## _ -## (return (list type)))) - -## (defsyntax #export (type type-syntax) -## (walk-syntax type-syntax)) - -## (defsyntax #export (deftype [[name args] %usage] body) -## (return (list (` (def (~ name) -## (:' Type -## (type (All [(~@ args)] -## (~ body))))))))) +## ## (list+ (#Symbol name) tokens') +## ## [tokens' [(#Symbol name) (list)]] + +## ## (list+ (#Form (list+ (#Symbol name) args)) tokens') +## ## [tokens' [(#Symbol name) args]])) + +## ## (defsyntax (defsig +## ## [[name args] parse-ctor] +## ## [anns ($+ $1)]) +## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) +## ## (` (#Record (~ (untemplate-list ...)))) +## ## args)] +## ## (return (list (` (def (~ name) (~ def-body))))))) + +## ## (defsyntax (defstruct +## ## [[name args] parse-ctor] +## ## signature +## ## [defs ($+ $1)]) +## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) +## ## (` (#Record (~ (untemplate-list ...)))) +## ## args)] +## ## (return (list (` (def (~ name) +## ## (:' (~ def-body) (~ signature)))))))) + +## ## ## (def (with tokens) +## ## ## ...) + +## ## (import' lux) +## ## (module-alias' lux l) +## ## (import lux #as l #use [map]) + +## ## (defsyntax #export (All [name (%? %name)] [args %args] body) +## ## (let [name' (case name +## ## #None "" +## ## (#Some name) name) +## ## arg-replacements (map (lambda [arg] +## ## [(#Symbol ["" arg]) (` (#Bound (~ arg)))]) +## ## args) +## ## args' (map (lambda [arg] +## ## (#Symbol ["" arg])) +## ## args) +## ## body' (replace-syntax arg-replacements body)] +## ## (return (list (` (#AllT [#None (~ name') (#Tuple (list (~@ args'))) +## ## (~ body')])))))) + +## ## (def (walk-syntax type) +## ## (case type +## ## (#Meta [_ (#Form (\list& op args))]) +## ## (case op +## ## (#Meta [_ (#Symbol ident)]) +## ## (do' [macro?? (find-macro ident)] +## ## (case macro?? +## ## (#Some macro) +## ## (do' [expansion (macro args)] +## ## (flat-map% walk-syntax expansion)) + +## ## #None +## ## (do' [flat-map% (map% walk-syntax args)] +## ## (return (list (fold (lambda [fun arg] +## ## (` (#AppT [(~ fun) (~ arg)]))) +## ## op +## ## args)))))) + +## ## _ +## ## (do' [flat-map% (map% walk-syntax args)] +## ## (return (list (_meta (#Form (list op args'))))))) + +## ## _ +## ## (return (list type)))) + +## ## (defsyntax #export (type type-syntax) +## ## (walk-syntax type-syntax)) + +## ## (defsyntax #export (deftype [[name args] %usage] body) +## ## (return (list (` (def (~ name) +## ## (:' Type +## ## (type (All [(~@ args)] +## ## (~ body))))))))) |